Packages/MultiBuilds/CPRS28_REQUIRED.KID

KIDS Distribution saved on Feb 10, 2011@10:53:25
CPRS28 REQUIRED PATCHES   RELEASED
**KIDS**:CPRS28 REQUIRED 1.0^OR*3.0*293^GMRA*4.0*45^GMRC*3.0*66^

**INSTALL NAME**
CPRS28 REQUIRED 1.0
"BLD",19525,0)
CPRS28 REQUIRED 1.0^^1^3110210^y
"BLD",19525,6.3)
1
"BLD",19525,10,0)
^9.63^3^3
"BLD",19525,10,1,0)
OR*3.0*293^1
"BLD",19525,10,2,0)
GMRA*4.0*45^1
"BLD",19525,10,3,0)
GMRC*3.0*66^1
"BLD",19525,10,"B","GMRA*4.0*45",2)

"BLD",19525,10,"B","GMRC*3.0*66",3)

"BLD",19525,10,"B","OR*3.0*293",1)

"MBREQ")
0
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"VER")
8.0^22.0
**INSTALL NAME**
OR*3.0*293
"BLD",18545,0)
OR*3.0*293^ORDER ENTRY/RESULTS REPORTING^0^3110210^y
"BLD",18545,4,0)
^9.64PA^100.05^1
"BLD",18545,4,100.05,0)
100.05
"BLD",18545,4,100.05,222)
y^y^f^^^^n
"BLD",18545,4,"B",100.05,100.05)

"BLD",18545,6)
11^
"BLD",18545,6.3)
20
"BLD",18545,"INIT")
POST^ORY293
"BLD",18545,"KRN",0)
^9.67PA^779.2^20
"BLD",18545,"KRN",.4,0)
.4
"BLD",18545,"KRN",.401,0)
.401
"BLD",18545,"KRN",.402,0)
.402
"BLD",18545,"KRN",.403,0)
.403
"BLD",18545,"KRN",.5,0)
.5
"BLD",18545,"KRN",.84,0)
.84
"BLD",18545,"KRN",3.6,0)
3.6
"BLD",18545,"KRN",3.8,0)
3.8
"BLD",18545,"KRN",9.2,0)
9.2
"BLD",18545,"KRN",9.8,0)
9.8
"BLD",18545,"KRN",9.8,"NM",0)
^9.68A^8^8
"BLD",18545,"KRN",9.8,"NM",1,0)
OROCAPI1^^0^B44849780
"BLD",18545,"KRN",9.8,"NM",2,0)
ORCHECK^^0^B56557816
"BLD",18545,"KRN",9.8,"NM",3,0)
ORCSAVE^^0^B74510622
"BLD",18545,"KRN",9.8,"NM",4,0)
ORCSAVE2^^0^B68162412
"BLD",18545,"KRN",9.8,"NM",5,0)
ORMBLDPS^^0^B77690426
"BLD",18545,"KRN",9.8,"NM",6,0)
ORQ2^^0^B46973301
"BLD",18545,"KRN",9.8,"NM",7,0)
ORSRCHOR^^0^B81351241
"BLD",18545,"KRN",9.8,"NM",8,0)
ORY293^^0^B2220767
"BLD",18545,"KRN",9.8,"NM","B","ORCHECK",2)

"BLD",18545,"KRN",9.8,"NM","B","ORCSAVE",3)

"BLD",18545,"KRN",9.8,"NM","B","ORCSAVE2",4)

"BLD",18545,"KRN",9.8,"NM","B","ORMBLDPS",5)

"BLD",18545,"KRN",9.8,"NM","B","OROCAPI1",1)

"BLD",18545,"KRN",9.8,"NM","B","ORQ2",6)

"BLD",18545,"KRN",9.8,"NM","B","ORSRCHOR",7)

"BLD",18545,"KRN",9.8,"NM","B","ORY293",8)

"BLD",18545,"KRN",19,0)
19
"BLD",18545,"KRN",19.1,0)
19.1
"BLD",18545,"KRN",101,0)
101
"BLD",18545,"KRN",409.61,0)
409.61
"BLD",18545,"KRN",771,0)
771
"BLD",18545,"KRN",779.2,0)
779.2
"BLD",18545,"KRN",870,0)
870
"BLD",18545,"KRN",8989.51,0)
8989.51
"BLD",18545,"KRN",8989.52,0)
8989.52
"BLD",18545,"KRN",8994,0)
8994
"BLD",18545,"KRN","B",.4,.4)

"BLD",18545,"KRN","B",.401,.401)

"BLD",18545,"KRN","B",.402,.402)

"BLD",18545,"KRN","B",.403,.403)

"BLD",18545,"KRN","B",.5,.5)

"BLD",18545,"KRN","B",.84,.84)

"BLD",18545,"KRN","B",3.6,3.6)

"BLD",18545,"KRN","B",3.8,3.8)

"BLD",18545,"KRN","B",9.2,9.2)

"BLD",18545,"KRN","B",9.8,9.8)

"BLD",18545,"KRN","B",19,19)

"BLD",18545,"KRN","B",19.1,19.1)

"BLD",18545,"KRN","B",101,101)

"BLD",18545,"KRN","B",409.61,409.61)

"BLD",18545,"KRN","B",771,771)

"BLD",18545,"KRN","B",779.2,779.2)

"BLD",18545,"KRN","B",870,870)

"BLD",18545,"KRN","B",8989.51,8989.51)

"BLD",18545,"KRN","B",8989.52,8989.52)

"BLD",18545,"KRN","B",8994,8994)

"BLD",18545,"QUES",0)
^9.62^^
"BLD",18545,"REQB",0)
^9.611^2^2
"BLD",18545,"REQB",1,0)
OR*3.0*282^2
"BLD",18545,"REQB",2,0)
OR*3.0*303^2
"BLD",18545,"REQB","B","OR*3.0*282",1)

"BLD",18545,"REQB","B","OR*3.0*303",2)

"FIA",100.05)
ORDER CHECK INSTANCES
"FIA",100.05,0)
^ORD(100.05,
"FIA",100.05,0,0)
100.05P
"FIA",100.05,0,1)
y^y^f^^^^n
"FIA",100.05,0,10)

"FIA",100.05,0,11)

"FIA",100.05,0,"RLRO")

"FIA",100.05,0,"VR")
3.0^OR
"FIA",100.05,100.05)
0
"FIA",100.05,100.515)
0
"FIA",100.05,100.5152)
0
"FIA",100.05,100.5153)
0
"FIA",100.05,100.51534)
0
"FIA",100.05,100.518)
0
"FIA",100.05,100.57)
0
"FIA",100.05,100.58)
0
"INIT")
POST^ORY293
"IX",100.05,100.05,"C",0)
100.05^C^USED FOR FINDING ORDER CHECKS BASED ON OCCURENCE^R^^R^IR^I^100.05^^^^^LS
"IX",100.05,100.05,"C",.1,0)
^^2^2^3090121^
"IX",100.05,100.05,"C",.1,1,0)
This Index is used to increase the performance of the lookup of order 
"IX",100.05,100.05,"C",.1,2,0)
check instances based on the Occurrence descriptor and the Order number.
"IX",100.05,100.05,"C",1)
S ^ORD(100.05,"C",X(1),$E(X(2),1,30),DA)=""
"IX",100.05,100.05,"C",2)
K ^ORD(100.05,"C",X(1),$E(X(2),1,30),DA)
"IX",100.05,100.05,"C",2.5)
K ^ORD(100.05,"C")
"IX",100.05,100.05,"C",11.1,0)
^.114IA^2^2
"IX",100.05,100.05,"C",11.1,1,0)
1^F^100.05^.01^^1^F
"IX",100.05,100.05,"C",11.1,2,0)
2^F^100.05^2^30^2^F
"IX",100.05,100.05,"D",0)
100.05^D^USED FOR FINDING ORDER CHECKS BASED ON OC TYPE^R^^F^IR^I^100.05^^^^^LS
"IX",100.05,100.05,"D",1)
S ^ORD(100.05,"D",X,DA)=""
"IX",100.05,100.05,"D",2)
K ^ORD(100.05,"D",X,DA)
"IX",100.05,100.05,"D",2.5)
K ^ORD(100.05,"D")
"IX",100.05,100.05,"D",11.1,0)
^.114IA^2^1
"IX",100.05,100.05,"D",11.1,2,0)
1^F^100.05^5^^1^F
"IX",100.05,100.05,"D",11.1,2,3)

"MBREQ")
1
"PKG",22,-1)
1^1
"PKG",22,0)
ORDER ENTRY/RESULTS REPORTING^OR^Order Entry/Results Reporting
"PKG",22,20,0)
^9.402P^^
"PKG",22,22,0)
^9.49I^1^1
"PKG",22,22,1,0)
3.0^2971217^2980204^64
"PKG",22,22,1,"PAH",1,0)
293^3110210^1392
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
8
"RTN","ORCHECK")
0^2^B56557816
"RTN","ORCHECK",1,0)
ORCHECK ;SLC/MKB-Order checking calls ; 9/28/2009 15:00
"RTN","ORCHECK",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215,243,293**;Dec 17, 1997;Build 20
"RTN","ORCHECK",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","ORCHECK",4,0)
DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED]
"RTN","ORCHECK",5,0)
 ;    Expects ORVP, ORNMSP, ORTAB, [ORWARD]
"RTN","ORCHECK",6,0)
 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
"RTN","ORCHECK",7,0)
 N ORX,ORY,I
"RTN","ORCHECK",8,0)
 I ORNMSP="PS" D  ;reset to PSJ, PSJI, or PSO
"RTN","ORCHECK",9,0)
 . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I)  S ORNMSP="PS"_$S(I="UD":"I",1:I) Q
"RTN","ORCHECK",10,0)
 . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list
"RTN","ORCHECK",11,0)
 S ORX(1)="|"_ORNMSP,ORX=1
"RTN","ORCHECK",12,0)
 D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY)
"RTN","ORCHECK",13,0)
 S I=0 F  S I=$O(ORY(I)) Q:I'>0  W !,$P(ORY(I),U,4) ; display only
"RTN","ORCHECK",14,0)
 Q
"RTN","ORCHECK",15,0)
 ;
"RTN","ORCHECK",16,0)
SELECT ; -- SELECT event
"RTN","ORCHECK",17,0)
 ;    Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP
"RTN","ORCHECK",18,0)
 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
"RTN","ORCHECK",19,0)
 N ORX,ORY,OI
"RTN","ORCHECK",20,0)
 S OI=+$G(ORDIALOG(PROMPT,ORI))
"RTN","ORCHECK",21,0)
 S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI)
"RTN","ORCHECK",22,0)
 D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY)
"RTN","ORCHECK",23,0)
 Q
"RTN","ORCHECK",24,0)
 ;
"RTN","ORCHECK",25,0)
ACCEPT(MODE) ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED]
"RTN","ORCHECK",26,0)
 ;    Expects ORVP, ORDIALOG(), ORNMSP
"RTN","ORCHECK",27,0)
 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
"RTN","ORCHECK",28,0)
 N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP
"RTN","ORCHECK",29,0)
 S:'$L($G(MODE)) MODE="ACCEPT"
"RTN","ORCHECK",30,0)
 S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0
"RTN","ORCHECK",31,0)
 S ORI=0 F  S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0  D STUF
"RTN","ORCHECK",32,0)
 I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F  S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0  D STUF
"RTN","ORCHECK",33,0)
 D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY)
"RTN","ORCHECK",34,0)
 Q
"RTN","ORCHECK",35,0)
STUF S ORIT=ORDIALOG(OI,ORI),ORSP=""
"RTN","ORCHECK",36,0)
 S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI))
"RTN","ORCHECK",37,0)
 S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT))
"RTN","ORCHECK",38,0)
 S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID
"RTN","ORCHECK",39,0)
 I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY)
"RTN","ORCHECK",40,0)
 S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ
"RTN","ORCHECK",41,0)
 Q
"RTN","ORCHECK",42,0)
 ;
"RTN","ORCHECK",43,0)
DELAY(MODE) ; -- Delayed ACCEPT event [called from ORMEVNT]
"RTN","ORCHECK",44,0)
 ;    Expects ORVP, ORIFN
"RTN","ORCHECK",45,0)
 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
"RTN","ORCHECK",46,0)
 N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF"
"RTN","ORCHECK",47,0)
 D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY)
"RTN","ORCHECK",48,0)
 D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q  ; silent
"RTN","ORCHECK",49,0)
 Q
"RTN","ORCHECK",50,0)
 ;
"RTN","ORCHECK",51,0)
BLD(ORDER) ; -- Build new ORX(#) for ORDER
"RTN","ORCHECK",52,0)
 Q:'$G(ORDER)  Q:'$D(^OR(100,ORDER,0))  ;Q:$P($G(^(3)),U,11)  ;edit/renew
"RTN","ORCHECK",53,0)
 N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST
"RTN","ORCHECK",54,0)
 S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1)
"RTN","ORCHECK",55,0)
 I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI)
"RTN","ORCHECK",56,0)
 S START=$$START(ORDER),ORI=0
"RTN","ORCHECK",57,0)
 F  S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0  D
"RTN","ORCHECK",58,0)
 . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1))
"RTN","ORCHECK",59,0)
 . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM))
"RTN","ORCHECK",60,0)
 . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"")
"RTN","ORCHECK",61,0)
 . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC
"RTN","ORCHECK",62,0)
 Q
"RTN","ORCHECK",63,0)
 ;
"RTN","ORCHECK",64,0)
REMDUPS ;
"RTN","ORCHECK",65,0)
 N IFN,CDL,I
"RTN","ORCHECK",66,0)
 S IFN=0 F  S IFN=$O(ORCHECK(IFN)) Q:'IFN  D
"RTN","ORCHECK",67,0)
 . S CDL=0 F  S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL  D
"RTN","ORCHECK",68,0)
 . . S I=0 F  S I=$O(ORCHECK(IFN,CDL,I)) Q:'I  D
"RTN","ORCHECK",69,0)
 . . . S J=I F  S J=$O(ORCHECK(IFN,CDL,J)) Q:'J  I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1
"RTN","ORCHECK",70,0)
 Q
"RTN","ORCHECK",71,0)
START(DA) ; -- Returns start date/time
"RTN","ORCHECK",72,0)
 N I,X,Y,%DT S Y=""
"RTN","ORCHECK",73,0)
 I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1))
"RTN","ORCHECK",74,0)
 E  D  ; look in ORDIALOG instead
"RTN","ORCHECK",75,0)
 . S I=0 F  S I=$O(ORDIALOG(I)) Q:I'>0  Q:$P(ORDIALOG(I),U,2)="START"
"RTN","ORCHECK",76,0)
 . S X=$S(I:$G(ORDIALOG(I,1)),1:"")
"RTN","ORCHECK",77,0)
 D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT"
"RTN","ORCHECK",78,0)
 D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST"
"RTN","ORCHECK",79,0)
 I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y=""
"RTN","ORCHECK",80,0)
 Q Y
"RTN","ORCHECK",81,0)
 ;
"RTN","ORCHECK",82,0)
DRUG(OI,PTR,IFN) ; -- Returns 6 ^-piece identifier for Dispense Drug
"RTN","ORCHECK",83,0)
 N ORDD,ORNDF,Y
"RTN","ORCHECK",84,0)
 I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1
"RTN","ORCHECK",85,0)
 I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1))
"RTN","ORCHECK",86,0)
 E  S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
"RTN","ORCHECK",87,0)
D1 Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD)
"RTN","ORCHECK",88,0)
 S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$$NAME50^ORPEAPI(ORDD)_"^99PSD"
"RTN","ORCHECK",89,0)
 Q Y
"RTN","ORCHECK",90,0)
 ;
"RTN","ORCHECK",91,0)
IV() ; -- Get Dispense Drug for IV orderable
"RTN","ORCHECK",92,0)
 N PSOI,TYPE,VOL,ORY
"RTN","ORCHECK",93,0)
 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL=""
"RTN","ORCHECK",94,0)
 S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B")
"RTN","ORCHECK",95,0)
 S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1)))
"RTN","ORCHECK",96,0)
 D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY)
"RTN","ORCHECK",97,0)
 Q +$G(ORY)
"RTN","ORCHECK",98,0)
 ;
"RTN","ORCHECK",99,0)
LIST(IFN) ; -- Displays list of ORCHECK(IFN) checks
"RTN","ORCHECK",100,0)
 N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF
"RTN","ORCHECK",101,0)
 S ORZ=0 F  S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0  D
"RTN","ORCHECK",102,0)
 . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High
"RTN","ORCHECK",103,0)
 . S ORI=0 F  S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0  D
"RTN","ORCHECK",104,0)
 . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>>  "_X_OFF Q
"RTN","ORCHECK",105,0)
 . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX)  ; wrap
"RTN","ORCHECK",106,0)
 . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>>  ",1:"      ")_ORTX(ORJ)_OFF
"RTN","ORCHECK",107,0)
 W !
"RTN","ORCHECK",108,0)
 Q
"RTN","ORCHECK",109,0)
 ;
"RTN","ORCHECK",110,0)
CANCEL() ; -- Returns 1 or 0: Cancel order(s)?
"RTN","ORCHECK",111,0)
 N X,Y,DIR,NUM
"RTN","ORCHECK",112,0)
 S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA"
"RTN","ORCHECK",113,0)
 S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ")
"RTN","ORCHECK",114,0)
 S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order.  If you wish to override these order checks"
"RTN","ORCHECK",115,0)
 S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks."
"RTN","ORCHECK",116,0)
 D ^DIR
"RTN","ORCHECK",117,0)
 Q +Y
"RTN","ORCHECK",118,0)
 ;
"RTN","ORCHECK",119,0)
REASON() ; -- Reason for overriding order checks
"RTN","ORCHECK",120,0)
 ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q  ??
"RTN","ORCHECK",121,0)
 N X,Y,DIR
"RTN","ORCHECK",122,0)
 S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: "
"RTN","ORCHECK",123,0)
 S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters"
"RTN","ORCHECK",124,0)
 D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^"
"RTN","ORCHECK",125,0)
 Q Y
"RTN","ORCHECK",126,0)
 ;
"RTN","ORCHECK",127,0)
SESSION ; -- SESSION event [called from ORCSIGN]
"RTN","ORCHECK",128,0)
 ;    Expects ORVP, ORES()
"RTN","ORCHECK",129,0)
 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E"
"RTN","ORCHECK",130,0)
 N ORX,ORY,ORIFN,I,X,Y
"RTN","ORCHECK",131,0)
 S ORIFN=0 F  S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0  I +$P(ORIFN,";",2)'>1 D
"RTN","ORCHECK",132,0)
 . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q  ;unreleased
"RTN","ORCHECK",133,0)
 . D BLD(+ORIFN) K ^TMP($J,"OCDATA") Q:'$$OCAPI^ORCHECK(+ORIFN,"OCDATA")
"RTN","ORCHECK",134,0)
 . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1
"RTN","ORCHECK",135,0)
 . S I=0 F  S I=$O(^TMP($J,"OCDATA",I)) Q:'I  D
"RTN","ORCHECK",136,0)
 . . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($G(^TMP($J,"OCDATA",I,"OC LEVEL")):^TMP($J,"OCDATA",I,"OC LEVEL"),1:99),ORCHECK)=$G(^TMP($J,"OCDATA",I,"OC NUMBER"))_U_$G(^TMP($J,"OCDATA",I,"OC LEVEL"))_U_$G(^TMP($J,"OCDATA",I,"OC TEXT",1,0))
"RTN","ORCHECK",137,0)
 . K ^TMP($J,"OCDATA")
"RTN","ORCHECK",138,0)
 I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS
"RTN","ORCHECK",139,0)
 Q
"RTN","ORCHECK",140,0)
 ;
"RTN","ORCHECK",141,0)
RETURN ; -- Return checks in ORCHECK(ORIFN,CDL,#)
"RTN","ORCHECK",142,0)
 N I,IFN,CDL S I=0 F  S I=$O(ORY(I)) Q:I'>0  D
"RTN","ORCHECK",143,0)
 . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW"
"RTN","ORCHECK",144,0)
 . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99
"RTN","ORCHECK",145,0)
 . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count
"RTN","ORCHECK",146,0)
 . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4)
"RTN","ORCHECK",147,0)
 Q
"RTN","ORCHECK",148,0)
 ;
"RTN","ORCHECK",149,0)
OCAPI(IFN,ORPLACE) ;IA #4859
"RTN","ORCHECK",150,0)
 ;LOOK AT ROUTINE OROCAPI1 FOR MORE DETAILED APIS
"RTN","ORCHECK",151,0)
 ;API to get the order checking info for a specific order (IFN)
"RTN","ORCHECK",152,0)
 ;info is stored in ^TMP($J,ORPLACE)
"RTN","ORCHECK",153,0)
 ;               ^TMP($J,ORPLACE,D0,"OC LEVEL")="order check level"
"RTN","ORCHECK",154,0)
 ;               ,"OC NUMBER")="file 100.8 ien"
"RTN","ORCHECK",155,0)
 ;                                                 ,"OC TEXT")="order check text"
"RTN","ORCHECK",156,0)
 ;                                                 ,"OR REASON")="over ride reason text"
"RTN","ORCHECK",157,0)
 ;                                                 ,"OR PROVIDER")="provider DUZ who entered over ride reason"
"RTN","ORCHECK",158,0)
 ;                                                 ,"OR DT")="date/time over ride reason was entered"
"RTN","ORCHECK",159,0)
 ; NOTE on OC LEVEL: 1 is HIGH, 2 is MODERATE, 3 is LOW
"RTN","ORCHECK",160,0)
 N RET,ORN,CNT,I,ORFLAG
"RTN","ORCHECK",161,0)
 S ORN=+IFN,CNT=0,ORFLAG=0
"RTN","ORCHECK",162,0)
 ;if the order is not released then show ACCEPTANCE_CPRS ocs
"RTN","ORCHECK",163,0)
 I "^14^13^11^"[(U_$P($G(^OR(100,ORN,3)),U,3)_U) D GETOC5^OROCAPI1(ORN,"ACCEPTANCE_CPRS",.RET) S ORFLAG=1
"RTN","ORCHECK",164,0)
 ;if it has been signed then show SIGNATURE_CPRS ocs
"RTN","ORCHECK",165,0)
 I 'ORFLAG D GETOC5^OROCAPI1(ORN,"SIGNATURE_CPRS",.RET)
"RTN","ORCHECK",166,0)
 I $D(RET) S I=0 F  S I=$O(RET(ORN,"DATA",I)) Q:'I  S CNT=CNT+1 D
"RTN","ORCHECK",167,0)
 .S ^TMP($J,ORPLACE,CNT,"OC NUMBER")=$P($G(RET(ORN,"DATA",I,1)),U)
"RTN","ORCHECK",168,0)
 .S ^TMP($J,ORPLACE,CNT,"OC LEVEL")=$P($G(RET(ORN,"DATA",I,1)),U,2)
"RTN","ORCHECK",169,0)
 .M ^TMP($J,ORPLACE,CNT,"OC TEXT")=RET(ORN,"DATA",I,"OC")
"RTN","ORCHECK",170,0)
 .S ^TMP($J,ORPLACE,CNT,"OR REASON")=$G(RET(ORN,"DATA",I,"OR",1,0))
"RTN","ORCHECK",171,0)
 .S ^TMP($J,ORPLACE,CNT,"OR PROVIDER")=$S($L(^TMP($J,ORPLACE,CNT,"OR REASON")):$P($G(RET(ORN,"DATA",I,0)),U,4),1:"")
"RTN","ORCHECK",172,0)
 .S ^TMP($J,ORPLACE,CNT,"OR DT")=$S($L(^TMP($J,ORPLACE,CNT,"OR REASON")):$P($G(RET(ORN,"DATA",I,0)),U,5),1:"")
"RTN","ORCHECK",173,0)
 .S ^TMP($J,ORPLACE,CNT,"OR STATUS")=$P($G(RET(ORN,"DATA",I,0)),U,2)
"RTN","ORCHECK",174,0)
 .S ^TMP($J,ORPLACE,CNT,"OC INSTANCE")=I
"RTN","ORCHECK",175,0)
 Q CNT
"RTN","ORCHECK",176,0)
 ;
"RTN","ORCSAVE")
0^3^B74510622
"RTN","ORCSAVE",1,0)
ORCSAVE ;SLC/MKB/JDL-Save ;09/28/2009 15:00
"RTN","ORCSAVE",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243,303,293**;Dec 17, 1997;Build 20
"RTN","ORCSAVE",3,0)
 ;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","ORCSAVE",4,0)
NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order
"RTN","ORCSAVE",5,0)
 ; Returns ORIFN = [new] order number, if created/saved
"RTN","ORCSAVE",6,0)
 D EN
"RTN","ORCSAVE",7,0)
 Q
"RTN","ORCSAVE",8,0)
 ;
"RTN","ORCSAVE",9,0)
XX ; -- save new/unreleased edited order into Orders file
"RTN","ORCSAVE",10,0)
 ;    Requires: ORDIALOG() = array of dialog values
"RTN","ORCSAVE",11,0)
 ;              ORIFN      = IFN of original order that was edited
"RTN","ORCSAVE",12,0)
 ;  
"RTN","ORCSAVE",13,0)
 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0
"RTN","ORCSAVE",14,0)
 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed
"RTN","ORCSAVE",15,0)
 D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1
"RTN","ORCSAVE",16,0)
 I $G(OLDIFN) D  ;save links between orders
"RTN","ORCSAVE",17,0)
 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1
"RTN","ORCSAVE",18,0)
 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
"RTN","ORCSAVE",19,0)
 I $D(^OR(100,+OLDIFN,0)) D
"RTN","ORCSAVE",20,0)
 . Q:'$G(OREVTDF)
"RTN","ORCSAVE",21,0)
 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN
"RTN","ORCSAVE",22,0)
 . S (OLDEVT,OLDSTS,LSTACT)=0
"RTN","ORCSAVE",23,0)
 . S NOW=$$NOW^XLFDT
"RTN","ORCSAVE",24,0)
 . S OLDEVT=$P(^OR(100,+OLDIFN,0),U,17),OLDSTS=$P(^OR(100,+OLDIFN,3),U,3)
"RTN","ORCSAVE",25,0)
 . ; Active status = 6 from #100.01
"RTN","ORCSAVE",26,0)
 . I (OLDEVT>0),OLDSTS=6 D
"RTN","ORCSAVE",27,0)
 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT
"RTN","ORCSAVE",28,0)
 . . S $P(^OR(100,+ORIFN,3),U,3)=11
"RTN","ORCSAVE",29,0)
 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7)
"RTN","ORCSAVE",30,0)
 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D
"RTN","ORCSAVE",31,0)
 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11
"RTN","ORCSAVE",32,0)
 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2)
"RTN","ORCSAVE",33,0)
 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U)
"RTN","ORCSAVE",34,0)
 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""
"RTN","ORCSAVE",35,0)
 Q
"RTN","ORCSAVE",36,0)
 ;
"RTN","ORCSAVE",37,0)
RN ; -- save new/unreleased renewal order into Orders file
"RTN","ORCSAVE",38,0)
 ;    Requires: ORDIALOG() = array of new dialog values
"RTN","ORCSAVE",39,0)
 ;              ORIFN      = IFN of original order that was renewed
"RTN","ORCSAVE",40,0)
 ; 
"RTN","ORCSAVE",41,0)
 N OLDIFN S OLDIFN=+ORIFN K ORIFN
"RTN","ORCSAVE",42,0)
 D EN Q:'ORIFN  S:'$G(ORDA) ORDA=1
"RTN","ORCSAVE",43,0)
 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2
"RTN","ORCSAVE",44,0)
 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
"RTN","ORCSAVE",45,0)
 Q
"RTN","ORCSAVE",46,0)
 ;
"RTN","ORCSAVE",47,0)
EN ; -- save new/unreleased order in ORDIALOG() into Orders file
"RTN","ORCSAVE",48,0)
 ;    Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]
"RTN","ORCSAVE",49,0)
 ;    If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC
"RTN","ORCSAVE",50,0)
 ;     (else use values from ORDIALOG and current state)
"RTN","ORCSAVE",51,0)
 ;
"RTN","ORCSAVE",52,0)
 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE,ORK
"RTN","ORCSAVE",53,0)
 Q:'$G(ORVP)  Q:'$G(ORDIALOG)  Q:'$D(^ORD(101.41,+ORDIALOG,0))
"RTN","ORCSAVE",54,0)
 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6)
"RTN","ORCSAVE",55,0)
 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O"))
"RTN","ORCSAVE",56,0)
 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7))
"RTN","ORCSAVE",57,0)
 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order
"RTN","ORCSAVE",58,0)
 S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5))
"RTN","ORCSAVE",59,0)
 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195
"RTN","ORCSAVE",60,0)
 E  S LOC=$G(ORL),TRSPEC=$G(ORTS)
"RTN","ORCSAVE",61,0)
 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0)
"RTN","ORCSAVE",62,0)
 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)
"RTN","ORCSAVE",63,0)
 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
"RTN","ORCSAVE",64,0)
 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN
"RTN","ORCSAVE",65,0)
EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT)
"RTN","ORCSAVE",66,0)
 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE
"RTN","ORCSAVE",67,0)
 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)=""
"RTN","ORCSAVE",68,0)
 S ^OR(100,"AF",LOG,ORIFN,1)=""
"RTN","ORCSAVE",69,0)
 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""
"RTN","ORCSAVE",70,0)
 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""
"RTN","ORCSAVE",71,0)
 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""
"RTN","ORCSAVE",72,0)
 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""
"RTN","ORCSAVE",73,0)
 ;check if OR GTX STUDY REASON is in ORDIALOG and strip out control characters
"RTN","ORCSAVE",74,0)
 N ORRFSID
"RTN","ORCSAVE",75,0)
 S ORRFSID=$O(^ORD(101.41,"B","OR GTX STUDY REASON",""))
"RTN","ORCSAVE",76,0)
 I ORRFSID,$D(ORDIALOG(ORRFSID,1)) D
"RTN","ORCSAVE",77,0)
 .N X,I
"RTN","ORCSAVE",78,0)
 .S X=ORDIALOG(ORRFSID,1)
"RTN","ORCSAVE",79,0)
 .F I=1:1:31 S X=$TR(X,$C(I))
"RTN","ORCSAVE",80,0)
 .S ORDIALOG(ORRFSID,1)=X
"RTN","ORCSAVE",81,0)
EN2 S ORIFN=+ORIFN D RESPONSE ; save responses
"RTN","ORCSAVE",82,0)
 I $P(^OR(100,ORIFN,0),"^",5) D  ;Copy orders PKI fix
"RTN","ORCSAVE",83,0)
 . N OI
"RTN","ORCSAVE",84,0)
 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI
"RTN","ORCSAVE",85,0)
 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
"RTN","ORCSAVE",86,0)
 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))
"RTN","ORCSAVE",87,0)
 . I $E($G(ORY))=2 S ORDEA=ORY
"RTN","ORCSAVE",88,0)
 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text
"RTN","ORCSAVE",89,0)
 S NODE=$G(^OR(100,ORIFN,0)) D  S ^OR(100,ORIFN,0)=NODE
"RTN","ORCSAVE",90,0)
 . S $P(NODE,U,4)=$G(ORNP) ; COST?
"RTN","ORCSAVE",91,0)
 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0))
"RTN","ORCSAVE",92,0)
 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value
"RTN","ORCSAVE",93,0)
 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0))
"RTN","ORCSAVE",94,0)
 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X
"RTN","ORCSAVE",95,0)
 S $P(^OR(100,ORIFN,3),U)=NOW
"RTN","ORCSAVE",96,0)
 I $G(ORCHECK) D  ; save order checks
"RTN","ORCSAVE",97,0)
 . S (CNT,CDL)=0 F  S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0  S I=0 D
"RTN","ORCSAVE",98,0)
 . . F  S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0  S X=ORCHECK("NEW",CDL,I) D
"RTN","ORCSAVE",99,0)
 . . . S ORK(I,1)=+ORIFN_U_"ACCEPTANCE_CPRS"_U_DUZ_U_$$NOW^XLFDT_U_$P(X,U)_U_CDL
"RTN","ORCSAVE",100,0)
 . . . S ORK(I,2)=$E($P(X,U,3),1,500)
"RTN","ORCSAVE",101,0)
 . I $D(ORK) D SAVEOC^OROCAPI1(.ORK)
"RTN","ORCSAVE",102,0)
 K ORDEA
"RTN","ORCSAVE",103,0)
ENQ Q
"RTN","ORCSAVE",104,0)
 ;
"RTN","ORCSAVE",105,0)
NEXTIFN() ; -- Returns next available ORIFN
"RTN","ORCSAVE",106,0)
 N I,HDR,LAST,TOTAL,DA
"RTN","ORCSAVE",107,0)
 L +^OR(100,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
"RTN","ORCSAVE",108,0)
 I '$T Q "^"
"RTN","ORCSAVE",109,0)
 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1)
"RTN","ORCSAVE",110,0)
 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0))
"RTN","ORCSAVE",111,0)
 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
"RTN","ORCSAVE",112,0)
 S ^OR(100,0)=HDR L -^OR(100,0)
"RTN","ORCSAVE",113,0)
 Q DA
"RTN","ORCSAVE",114,0)
 ;
"RTN","ORCSAVE",115,0)
RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)
"RTN","ORCSAVE",116,0)
 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X
"RTN","ORCSAVE",117,0)
 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5)
"RTN","ORCSAVE",118,0)
 S (PROMPT,CNT)=0 F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
"RTN","ORCSAVE",119,0)
 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
"RTN","ORCSAVE",120,0)
 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
"RTN","ORCSAVE",121,0)
 . S INST=0 F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
"RTN","ORCSAVE",122,0)
 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE=""  S CNT=CNT+1
"RTN","ORCSAVE",123,0)
 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
"RTN","ORCSAVE",124,0)
 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
"RTN","ORCSAVE",125,0)
 . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0
"RTN","ORCSAVE",126,0)
 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE
"RTN","ORCSAVE",127,0)
 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root
"RTN","ORCSAVE",128,0)
 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT
"RTN","ORCSAVE",129,0)
R1 ; [Reset] Orderables
"RTN","ORCSAVE",130,0)
 I $D(^OR(100,ORIFN,.1)) S I=0 F  S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0  S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref
"RTN","ORCSAVE",131,0)
 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D
"RTN","ORCSAVE",132,0)
 . S (I,CNT)=0
"RTN","ORCSAVE",133,0)
 . F  S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0  D
"RTN","ORCSAVE",134,0)
 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X
"RTN","ORCSAVE",135,0)
 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)=""
"RTN","ORCSAVE",136,0)
 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""
"RTN","ORCSAVE",137,0)
 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT
"RTN","ORCSAVE",138,0)
 Q
"RTN","ORCSAVE",139,0)
 ;
"RTN","ORCSAVE",140,0)
RESUME(IFN) ; -- add Response nodes for RESUME tray service
"RTN","ORCSAVE",141,0)
 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1
"RTN","ORCSAVE",142,0)
 ;
"RTN","ORCSAVE",143,0)
 N X,Y,DA,DIC,DLAYGO
"RTN","ORCSAVE",144,0)
 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT
"RTN","ORCSAVE",145,0)
 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2),DLAYGO=100
"RTN","ORCSAVE",146,0)
 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1
"RTN","ORCSAVE",147,0)
 Q
"RTN","ORCSAVE",148,0)
 ;
"RTN","ORCSAVE",149,0)
PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER
"RTN","ORCSAVE",150,0)
 Q:'$G(ORDER)  Q:'$G(PROV)
"RTN","ORCSAVE",151,0)
 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1
"RTN","ORCSAVE",152,0)
 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV
"RTN","ORCSAVE",153,0)
 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV
"RTN","ORCSAVE",154,0)
 Q
"RTN","ORCSAVE",155,0)
 ;
"RTN","ORCSAVE",156,0)
ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action
"RTN","ORCSAVE",157,0)
 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA
"RTN","ORCSAVE",158,0)
 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0
"RTN","ORCSAVE",159,0)
 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
"RTN","ORCSAVE",160,0)
 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
"RTN","ORCSAVE",161,0)
 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0))
"RTN","ORCSAVE",162,0)
 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr
"RTN","ORCSAVE",163,0)
 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4)
"RTN","ORCSAVE",164,0)
 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D
"RTN","ORCSAVE",165,0)
 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11  Q:$P(X,U,4)'=2
"RTN","ORCSAVE",166,0)
 . S NEXT=LAST I PAT,$P(X,U) D  ; kill old xref entries
"RTN","ORCSAVE",167,0)
 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT)
"RTN","ORCSAVE",168,0)
 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT)
"RTN","ORCSAVE",169,0)
 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1
"RTN","ORCSAVE",170,0)
 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)=""
"RTN","ORCSAVE",171,0)
 S ^OR(100,"AF",WHEN,DA,NEXT)=""
"RTN","ORCSAVE",172,0)
 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
"RTN","ORCSAVE",173,0)
 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
"RTN","ORCSAVE",174,0)
 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
"RTN","ORCSAVE",175,0)
 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON
"RTN","ORCSAVE",176,0)
 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR
"RTN","ORCSAVE",177,0)
 Q NEXT
"RTN","ORCSAVE",178,0)
 ;
"RTN","ORCSAVE",179,0)
SET(DLG) ; -- Create new parent for order set ORDIALOG
"RTN","ORCSAVE",180,0)
 ; Returns ORPIFN = ifn of new parent order for set
"RTN","ORCSAVE",181,0)
 ;
"RTN","ORCSAVE",182,0)
 Q:'$G(ORVP)  Q:'$G(DLG)  N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X
"RTN","ORCSAVE",183,0)
 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0=""  S ORPIFN=$$NEXTIFN Q:'ORPIFN
"RTN","ORCSAVE",184,0)
 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12))
"RTN","ORCSAVE",185,0)
 I $G(OREVENT) S ORLOC="",TRSPEC=""
"RTN","ORCSAVE",186,0)
 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6)
"RTN","ORCSAVE",187,0)
 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)=""
"RTN","ORCSAVE",188,0)
 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""
"RTN","ORCSAVE",189,0)
 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""
"RTN","ORCSAVE",190,0)
 ; AEVNT ??
"RTN","ORCSAVE",191,0)
 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text
"RTN","ORCSAVE",192,0)
 Q
"RTN","ORCSAVE2")
0^4^B68162412
"RTN","ORCSAVE2",1,0)
ORCSAVE2 ;SLC/MKB-Utilities to update an order ;09/28/2009 15:00
"RTN","ORCSAVE2",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265,243,293**;Dec 17, 1997;Build 20
"RTN","ORCSAVE2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","ORCSAVE2",4,0)
 ;
"RTN","ORCSAVE2",5,0)
STATUS(IFN,ST) ; -- Update status of order
"RTN","ORCSAVE2",6,0)
 Q:'$G(IFN)  Q:'$D(^OR(100,+IFN,0))  Q:$P($G(^(3)),U,3)=$G(ST)  ;no change
"RTN","ORCSAVE2",7,0)
 Q:'$G(ST)  Q:'$D(^ORD(100.01,+ST,0))
"RTN","ORCSAVE2",8,0)
 N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP
"RTN","ORCSAVE2",9,0)
 S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT
"RTN","ORCSAVE2",10,0)
 S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3
"RTN","ORCSAVE2",11,0)
 I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12))
"RTN","ORCSAVE2",12,0)
 I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN
"RTN","ORCSAVE2",13,0)
 I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent
"RTN","ORCSAVE2",14,0)
 D SETALL^ORDD100(+IFN)
"RTN","ORCSAVE2",15,0)
 Q
"RTN","ORCSAVE2",16,0)
 ;
"RTN","ORCSAVE2",17,0)
CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate
"RTN","ORCSAVE2",18,0)
 N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS
"RTN","ORCSAVE2",19,0)
 Q:'$D(^OR(100,ORIFN,0))  S ORSTS=$P($G(^(3)),U,3)
"RTN","ORCSAVE2",20,0)
 I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D  Q  ;Parent unrel'd - ck children
"RTN","ORCSAVE2",21,0)
 . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0  D  Q:'ALLRELSD
"RTN","ORCSAVE2",22,0)
 . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
"RTN","ORCSAVE2",23,0)
 . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0
"RTN","ORCSAVE2",24,0)
 . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending
"RTN","ORCSAVE2",25,0)
 S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0
"RTN","ORCSAVE2",26,0)
 F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0  D  Q:'ALLDONE
"RTN","ORCSAVE2",27,0)
 . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
"RTN","ORCSAVE2",28,0)
 . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q
"RTN","ORCSAVE2",29,0)
 . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q
"RTN","ORCSAVE2",30,0)
 . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q
"RTN","ORCSAVE2",31,0)
 . S ALLDONE=0 S:CHSTS=6 ACTIVE=1
"RTN","ORCSAVE2",32,0)
 I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q
"RTN","ORCSAVE2",33,0)
 I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active
"RTN","ORCSAVE2",34,0)
 Q
"RTN","ORCSAVE2",35,0)
 ;
"RTN","ORCSAVE2",36,0)
RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service
"RTN","ORCSAVE2",37,0)
 S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
"RTN","ORCSAVE2",38,0)
 Q:'$G(ORDER)  N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0))
"RTN","ORCSAVE2",39,0)
 S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0)))
"RTN","ORCSAVE2",40,0)
 S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)=""
"RTN","ORCSAVE2",41,0)
 ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)=""
"RTN","ORCSAVE2",42,0)
 S $P(OR0,U,16,17)=WHEN_U_WHO
"RTN","ORCSAVE2",43,0)
 S ^OR(100,ORDER,8,ACTION,0)=OR0
"RTN","ORCSAVE2",44,0)
 I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER)
"RTN","ORCSAVE2",45,0)
 ;Set the "AR" index.
"RTN","ORCSAVE2",46,0)
 D RS^ORDD100(ORDER,ACTION,ORVP,WHEN)
"RTN","ORCSAVE2",47,0)
 Q
"RTN","ORCSAVE2",48,0)
 ;
"RTN","ORCSAVE2",49,0)
STARTDT(DA) ; -- resolve Start and Stop dates from Responses
"RTN","ORCSAVE2",50,0)
 N X,Y,%DT,ORDG,ORT,ORLAB
"RTN","ORCSAVE2",51,0)
 S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3)
"RTN","ORCSAVE2",52,0)
 S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT=""
"RTN","ORCSAVE2",53,0)
 S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA)
"RTN","ORCSAVE2",54,0)
STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q  S:$L(ORT) X=X_"@"_ORT
"RTN","ORCSAVE2",55,0)
 D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST"
"RTN","ORCSAVE2",56,0)
 S %DT="T" D ^%DT Q:Y'>0  S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
"RTN","ORCSAVE2",57,0)
 S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
"RTN","ORCSAVE2",58,0)
STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1  S X=$$FMADD^XLFDT(Y,(X-1))
"RTN","ORCSAVE2",59,0)
 I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X)  S:$L(ORT) X=X_"@"_ORT
"RTN","ORCSAVE2",60,0)
 S %DT="T" D ^%DT Q:Y'>0  S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
"RTN","ORCSAVE2",61,0)
 S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A
"RTN","ORCSAVE2",62,0)
 Q
"RTN","ORCSAVE2",63,0)
 ;
"RTN","ORCSAVE2",64,0)
NEXT ; -- Resolve next lab collection to FM date/time
"RTN","ORCSAVE2",65,0)
 N ORTIME,ORDAY,NOW,NEXT,ENT
"RTN","ORCSAVE2",66,0)
 ;is referenced by DBIA #964
"RTN","ORCSAVE2",67,0)
 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"
"RTN","ORCSAVE2",68,0)
 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
"RTN","ORCSAVE2",69,0)
 S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1")
"RTN","ORCSAVE2",70,0)
 S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0
"RTN","ORCSAVE2",71,0)
 S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U)
"RTN","ORCSAVE2",72,0)
 Q
"RTN","ORCSAVE2",73,0)
 ;
"RTN","ORCSAVE2",74,0)
AM ; -- Resolve AM lab collection to FM date/time
"RTN","ORCSAVE2",75,0)
 N ORTIME,ORDAY,AM,NOW,ENT
"RTN","ORCSAVE2",76,0)
 ;is referenced by DBIA #964
"RTN","ORCSAVE2",77,0)
 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL"
"RTN","ORCSAVE2",78,0)
 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
"RTN","ORCSAVE2",79,0)
 S AM=$O(ORTIME(0)),NOW=$P($H,",",2)
"RTN","ORCSAVE2",80,0)
 S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1")
"RTN","ORCSAVE2",81,0)
 S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U)
"RTN","ORCSAVE2",82,0)
 Q
"RTN","ORCSAVE2",83,0)
 ;
"RTN","ORCSAVE2",84,0)
ADMIN(START) ; -- Resolve next/closest administration times to FM date/time
"RTN","ORCSAVE2",85,0)
 N PAT,SCH,OI,LOC,Y,I
"RTN","ORCSAVE2",86,0)
 I $G(DA) D  ;get data from order DA
"RTN","ORCSAVE2",87,0)
 . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC=""
"RTN","ORCSAVE2",88,0)
 . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first
"RTN","ORCSAVE2",89,0)
 . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE")
"RTN","ORCSAVE2",90,0)
 I '$G(DA) D  ;or look in ORDIALOG() instead
"RTN","ORCSAVE2",91,0)
 . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0))
"RTN","ORCSAVE2",92,0)
 . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I))
"RTN","ORCSAVE2",93,0)
 . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC=""
"RTN","ORCSAVE2",94,0)
 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI
"RTN","ORCSAVE2",95,0)
 ;is referenced by DBIA #3167
"RTN","ORCSAVE2",96,0)
 S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2)
"RTN","ORCSAVE2",97,0)
 Q
"RTN","ORCSAVE2",98,0)
 ;
"RTN","ORCSAVE2",99,0)
SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order
"RTN","ORCSAVE2",100,0)
 Q:'$G(DA)  S:'$G(WHAT) WHAT=1
"RTN","ORCSAVE2",101,0)
 N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref
"RTN","ORCSAVE2",102,0)
 S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"")
"RTN","ORCSAVE2",103,0)
 ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer
"RTN","ORCSAVE2",104,0)
 S ^OR(100,DA,8,WHAT,0)=X
"RTN","ORCSAVE2",105,0)
 D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref
"RTN","ORCSAVE2",106,0)
 Q
"RTN","ORCSAVE2",107,0)
 ;
"RTN","ORCSAVE2",108,0)
SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns]
"RTN","ORCSAVE2",109,0)
 ; Expects ORNATR, ORVP, ORNP to be defined
"RTN","ORCSAVE2",110,0)
 Q:'$G(IFN)  Q:'$G(ACT)  N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U)
"RTN","ORCSAVE2",111,0)
 S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3)
"RTN","ORCSAVE2",112,0)
 K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)
"RTN","ORCSAVE2",113,0)
 S $P(^OR(100,+IFN,8,ACT,0),U,4)=X
"RTN","ORCSAVE2",114,0)
 I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN
"RTN","ORCSAVE2",115,0)
 Q
"RTN","ORCSAVE2",116,0)
 ;
"RTN","ORCSAVE2",117,0)
UNVEIL(IFN) ; -- unveil new order
"RTN","ORCSAVE2",118,0)
 S $P(^OR(100,IFN,3),U,8)=""
"RTN","ORCSAVE2",119,0)
 Q
"RTN","ORCSAVE2",120,0)
 ;
"RTN","ORCSAVE2",121,0)
DELETE(ORDER) ; -- delete order [action]
"RTN","ORCSAVE2",122,0)
 N DIK,DA,DAD
"RTN","ORCSAVE2",123,0)
 I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q
"RTN","ORCSAVE2",124,0)
 S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent
"RTN","ORCSAVE2",125,0)
 K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text
"RTN","ORCSAVE2",126,0)
 D DELETE^OROCAPI1(+ORDER)
"RTN","ORCSAVE2",127,0)
 Q
"RTN","ORCSAVE2",128,0)
 ;
"RTN","ORCSAVE2",129,0)
VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified
"RTN","ORCSAVE2",130,0)
 Q:'$G(IFN)  Q:'$G(DA)  Q:"^N^C^R^"'[(U_$G(TYPE)_U)
"RTN","ORCSAVE2",131,0)
 N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18)
"RTN","ORCSAVE2",132,0)
 S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
"RTN","ORCSAVE2",133,0)
 S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN
"RTN","ORCSAVE2",134,0)
 D:$L($T(VER^EDPFMON)) VER^EDPFMON(IFN)
"RTN","ORCSAVE2",135,0)
 Q
"RTN","ORCSAVE2",136,0)
 ;
"RTN","ORCSAVE2",137,0)
COMP(IFN,WHO,WHEN) ; -- order completed
"RTN","ORCSAVE2",138,0)
 Q:'$G(IFN)  S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
"RTN","ORCSAVE2",139,0)
 D DATES(+IFN,,WHEN),STATUS(+IFN,2)
"RTN","ORCSAVE2",140,0)
 S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO
"RTN","ORCSAVE2",141,0)
 D:$L($T(COMP^EDPFMON)) COMP^EDPFMON(IFN)
"RTN","ORCSAVE2",142,0)
 Q
"RTN","ORCSAVE2",143,0)
 ;
"RTN","ORCSAVE2",144,0)
DATES(DA,START,STOP) ; -- Update start/stop dates for order DA
"RTN","ORCSAVE2",145,0)
 Q:'$G(DA)  I $G(START) D
"RTN","ORCSAVE2",146,0)
 . Q:START=$P(^OR(100,DA,0),U,8)
"RTN","ORCSAVE2",147,0)
 . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA)
"RTN","ORCSAVE2",148,0)
 . S $P(^OR(100,DA,0),U,8)=START
"RTN","ORCSAVE2",149,0)
 . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
"RTN","ORCSAVE2",150,0)
 I $G(STOP) D
"RTN","ORCSAVE2",151,0)
 . ;Q:STOP=$P(^OR(100,DA,0),U,9)  ;ck xref anyway
"RTN","ORCSAVE2",152,0)
 . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A
"RTN","ORCSAVE2",153,0)
 Q
"RTN","ORCSAVE2",154,0)
 ;
"RTN","ORCSAVE2",155,0)
OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9) ON SIGNATURE IN CPRS
"RTN","ORCSAVE2",156,0)
 Q:'$G(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))
"RTN","ORCSAVE2",157,0)
 D DELOCC^OROCAPI1(+ORIFN,"SIGNATURE_CPRS")
"RTN","ORCSAVE2",158,0)
 N I,J,ORK,CNT,OC,OROCRET
"RTN","ORCSAVE2",159,0)
 S CNT=0
"RTN","ORCSAVE2",160,0)
 S I=0 F  S I=$O(ORCHECK(+ORIFN,I)) Q:'I  D
"RTN","ORCSAVE2",161,0)
 . S J=0 F  S J=$O(ORCHECK(+ORIFN,I,J)) Q:'J  D
"RTN","ORCSAVE2",162,0)
 . . S OC=ORCHECK(+ORIFN,I,J)
"RTN","ORCSAVE2",163,0)
 . . S CNT=CNT+1
"RTN","ORCSAVE2",164,0)
 . . S ORK(CNT,1)=+ORIFN_U_"SIGNATURE_CPRS"_U_DUZ_U_$$NOW^XLFDT_U_+OC_U_I
"RTN","ORCSAVE2",165,0)
 . . S ORK(CNT,2)=$E($P(OC,U,3),1,500)
"RTN","ORCSAVE2",166,0)
 . . S ORK(CNT,3)=$S(I=1:ORCHECK("OK"),1:"")
"RTN","ORCSAVE2",167,0)
 I $D(ORK) D SAVEOC^OROCAPI1(.ORK)
"RTN","ORCSAVE2",168,0)
 Q
"RTN","ORCSAVE2",169,0)
 ;
"RTN","ORCSAVE2",170,0)
VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID
"RTN","ORCSAVE2",171,0)
 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""
"RTN","ORCSAVE2",172,0)
 N I,Y S I=0,Y="" S:'$G(INST) INST=1
"RTN","ORCSAVE2",173,0)
 F  S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0  I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q
"RTN","ORCSAVE2",174,0)
 Q Y
"RTN","ORCSAVE2",175,0)
 ;
"RTN","ORCSAVE2",176,0)
SC(ORX,ORIFN) ; -- save responses to SC questions
"RTN","ORCSAVE2",177,0)
 Q:'$G(ORIFN)  Q:'$D(^OR(100,+ORIFN,0))  ;invalid order number
"RTN","ORCSAVE2",178,0)
 N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0
"RTN","ORCSAVE2",179,0)
 F I="SC","MST","AO","IR","EC","HNC","CV","SHD" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I)
"RTN","ORCSAVE2",180,0)
 S ^OR(100,+ORIFN,5)=OR5
"RTN","ORCSAVE2",181,0)
 Q
"RTN","ORCSAVE2",182,0)
 ;
"RTN","ORCSAVE2",183,0)
CANCEL(ORDER) ; -- cancel order [action]
"RTN","ORCSAVE2",184,0)
 N ORA,DIE,DA,DR,ORX
"RTN","ORCSAVE2",185,0)
 S ORDER=$G(ORDER),ORA=+$P(ORDER,";",2) Q:'ORA!('ORDER)
"RTN","ORCSAVE2",186,0)
 I $D(^OR(100,+ORDER,8,ORA)) D
"RTN","ORCSAVE2",187,0)
 .S ORX="Unsigned/unreleased order cancelled by provider"
"RTN","ORCSAVE2",188,0)
 .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
"RTN","ORCSAVE2",189,0)
 .S DR="4////5;15////13;1////^S X=ORX" D ^DIE
"RTN","ORCSAVE2",190,0)
 I ORA=1 D
"RTN","ORCSAVE2",191,0)
 .K DA S DIE="^OR(100,",DA=+ORDER,DR="5////13" D ^DIE
"RTN","ORCSAVE2",192,0)
 Q
"RTN","ORCSAVE2",193,0)
 ;
"RTN","ORCSAVE2",194,0)
LAPSE(ORDER) ; -- lapse order [action]
"RTN","ORCSAVE2",195,0)
 N ORA S ORA=+$P(ORDER,";",2)
"RTN","ORCSAVE2",196,0)
 Q:'$D(^OR(100,+ORDER,0))  Q:'ORA!('ORDER)
"RTN","ORCSAVE2",197,0)
 I $D(^OR(100,+ORDER,8,ORA)) D
"RTN","ORCSAVE2",198,0)
 .N DIE,DA,DR
"RTN","ORCSAVE2",199,0)
 .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
"RTN","ORCSAVE2",200,0)
 .S DR="4////5;15////14" D ^DIE
"RTN","ORCSAVE2",201,0)
 I ORA=1 D
"RTN","ORCSAVE2",202,0)
 .N DIE,DA,DR
"RTN","ORCSAVE2",203,0)
 .S DIE="^OR(100,",DA=+ORDER,DR="5////14"
"RTN","ORCSAVE2",204,0)
 .D ^DIE,ALPS(DA,ORA)
"RTN","ORCSAVE2",205,0)
 Q
"RTN","ORCSAVE2",206,0)
ALPS(DA,ORACT,TYPE) ;set the lapse index ^OR(100,"ALPS")
"RTN","ORCSAVE2",207,0)
 N ORVP,X,OR0,ORLOG
"RTN","ORCSAVE2",208,0)
 S OR0=$G(^OR(100,DA,8,ORACT,0))
"RTN","ORCSAVE2",209,0)
 S ORLOG=$P(OR0,U),ORVP=$P($G(^OR(100,DA,0)),U,2)
"RTN","ORCSAVE2",210,0)
 I ORVP,ORLOG S ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$G(TYPE)
"RTN","ORCSAVE2",211,0)
 S ^OR(100,DA,10)=$$NOW^XLFDT
"RTN","ORCSAVE2",212,0)
 Q
"RTN","ORCSAVE2",213,0)
 ;
"RTN","ORCSAVE2",214,0)
RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue
"RTN","ORCSAVE2",215,0)
 S IFN=+$G(IFN),VAL=$G(VAL),PRMT=+$O(^ORD(101.41,"AB",PRMT,0))
"RTN","ORCSAVE2",216,0)
 N ID,DA,DIK S:'$G(INST) INST=1
"RTN","ORCSAVE2",217,0)
 S ID=$P($G(^ORD(101.41,PRMT,1)),U,3) Q:'$L(ID)
"RTN","ORCSAVE2",218,0)
 S DA=0 F  S DA=$O(^OR(100,IFN,4.5,"ID",ID,DA)) Q:DA<1  Q:$P($G(^OR(100,IFN,4.5,DA,0)),U,3)=INST
"RTN","ORCSAVE2",219,0)
 I 'DA D:$L(VAL)  Q  ;add
"RTN","ORCSAVE2",220,0)
 . N DO,DIC,DLG,X
"RTN","ORCSAVE2",221,0)
 . S DIC="^OR(100,"_IFN_",4.5,",DA(1)=IFN,DIC(0)="FL"
"RTN","ORCSAVE2",222,0)
 . S DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID
"RTN","ORCSAVE2",223,0)
 . S DLG=+$P($G(^OR(100,IFN,0)),U,5)
"RTN","ORCSAVE2",224,0)
 . S X=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
"RTN","ORCSAVE2",225,0)
 . D FILE^DICN S:Y ^OR(100,IFN,4.5,+Y,1)=VAL
"RTN","ORCSAVE2",226,0)
 I $L(VAL) S ^OR(100,IFN,4.5,DA,1)=VAL Q  ;change
"RTN","ORCSAVE2",227,0)
 S DIK="^OR(100,"_IFN_",4.5,",DA(1)=IFN D ^DIK ;delete
"RTN","ORCSAVE2",228,0)
 Q
"RTN","ORMBLDPS")
0^5^B77690426
"RTN","ORMBLDPS",1,0)
ORMBLDPS ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;09/28/2009 15:00
"RTN","ORMBLDPS",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254,243,293**;Dec 17, 1997;Build 20
"RTN","ORMBLDPS",3,0)
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
"RTN","ORMBLDPS",4,0)
 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
"RTN","ORMBLDPS",5,0)
 ;
"RTN","ORMBLDPS",6,0)
NVA ; -- new Non-VA Meds order
"RTN","ORMBLDPS",7,0)
 N NVA S NVA=1
"RTN","ORMBLDPS",8,0)
OUT ; -- new Outpt Meds order [same as UD, +3 fields]
"RTN","ORMBLDPS",9,0)
UD ; -- new Inpt (Unit Dose) Meds order
"RTN","ORMBLDPS",10,0)
 N ADMIN,OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT,OITXT,OITXT2
"RTN","ORMBLDPS",11,0)
 N QT7,SCHTYPE
"RTN","ORMBLDPS",12,0)
 S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag
"RTN","ORMBLDPS",13,0)
 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different
"RTN","ORMBLDPS",14,0)
 S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG")
"RTN","ORMBLDPS",15,0)
 S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES")
"RTN","ORMBLDPS",16,0)
 S SCHTYPE=$$PTR("SCHEDULE TYPE")
"RTN","ORMBLDPS",17,0)
 S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE")
"RTN","ORMBLDPS",18,0)
 S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1")
"RTN","ORMBLDPS",19,0)
 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN")
"RTN","ORMBLDPS",20,0)
 S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|"
"RTN","ORMBLDPS",21,0)
 I +$G(NVA)=1 G NVA1
"RTN","ORMBLDPS",22,0)
UD1 S I=0 F  S I=$O(ORDIALOG(INSTR,I)) Q:I'>0  D
"RTN","ORMBLDPS",23,0)
 . S X=$G(ORDIALOG(DOSE,I))
"RTN","ORMBLDPS",24,0)
 . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"")
"RTN","ORMBLDPS",25,0)
 . S QT2=$$ESC($G(ORDIALOG(SCHED,I)))_$S(OUTPT:"",1:"&"_$G(ORDIALOG(ADMIN,I)))
"RTN","ORMBLDPS",26,0)
 . S QT3=$$HL7DUR
"RTN","ORMBLDPS",27,0)
 . S QT1=$S($L(X):$P(X,"&",1,6),1:"")
"RTN","ORMBLDPS",28,0)
 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2)
"RTN","ORMBLDPS",29,0)
 . S QT7=$G(ORDIALOG(SCHTYPE,I))
"RTN","ORMBLDPS",30,0)
 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~"
"RTN","ORMBLDPS",31,0)
 . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_U_QT7_U_$$INSTR_U_QT9
"RTN","ORMBLDPS",32,0)
 ;
"RTN","ORMBLDPS",33,0)
NVA1 I +$G(NVA)=1 D
"RTN","ORMBLDPS",34,0)
 . S I=1 ;only one dosage possible for non-va meds
"RTN","ORMBLDPS",35,0)
 . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I))
"RTN","ORMBLDPS",36,0)
 . S QT1=$S($L(X):$P(X,"&",1,6),1:"")
"RTN","ORMBLDPS",37,0)
 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2)
"RTN","ORMBLDPS",38,0)
 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~"
"RTN","ORMBLDPS",39,0)
 . S J=J+1,ORC(J)=QT1_U_$$ESC(QT2)_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9
"RTN","ORMBLDPS",40,0)
 ;
"RTN","ORMBLDPS",41,0)
 I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2
"RTN","ORMBLDPS",42,0)
 S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0
"RTN","ORMBLDPS",43,0)
 F J=1:1:ORC S Y=ORC(J) D  ;add to ORMSG(4)
"RTN","ORMBLDPS",44,0)
 . I $L(@X)+$L(Y)'>245 S @X=@X_Y
"RTN","ORMBLDPS",45,0)
 . E  S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y))
"RTN","ORMBLDPS",46,0)
 I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD"
"RTN","ORMBLDPS",47,0)
 S OITXT=$$USID^ORMBLD($G(ORDIALOG(OI,1)))
"RTN","ORMBLDPS",48,0)
 S OITXT2=$P(OITXT,U,1,4)_U_$$ESC($P(OITXT,U,5))_U_$P(OITXT,U,6,99)
"RTN","ORMBLDPS",49,0)
 S ORMSG(5)="RXO|"_OITXT2_"|||||||||"_$G(DISPENSE)
"RTN","ORMBLDPS",50,0)
UD2 I $G(OUTPT) D
"RTN","ORMBLDPS",51,0)
 . N QTY,REFS,DSPY
"RTN","ORMBLDPS",52,0)
 . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY")
"RTN","ORMBLDPS",53,0)
 . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1))
"RTN","ORMBLDPS",54,0)
 S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D
"RTN","ORMBLDPS",55,0)
 . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J
"RTN","ORMBLDPS",56,0)
 . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,PROVCOMM,1,J,0)))
"RTN","ORMBLDPS",57,0)
 . S K=0 F  S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0  S K=K+1,ORMSG(6,K)=$G(^(J,0))
"RTN","ORMBLDPS",58,0)
 I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D
"RTN","ORMBLDPS",59,0)
 . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J
"RTN","ORMBLDPS",60,0)
 . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0))
"RTN","ORMBLDPS",61,0)
 . S K=0 F  S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0  S K=K+1,ORMSG(I,K)=$G(^(J,0))
"RTN","ORMBLDPS",62,0)
UD3 S J=0 F  S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0  S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J)))
"RTN","ORMBLDPS",63,0)
 D ORDCHKS
"RTN","ORMBLDPS",64,0)
 S I=I+1,ORMSG(I)=$$ZRX(IFN,OUTPT)
"RTN","ORMBLDPS",65,0)
 I $G(OUTPT) D  ;add SC data
"RTN","ORMBLDPS",66,0)
 . N OR5 S OR5=$G(^OR(100,IFN,5))
"RTN","ORMBLDPS",67,0)
 . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q
"RTN","ORMBLDPS",68,0)
 . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC")
"RTN","ORMBLDPS",69,0)
 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
"RTN","ORMBLDPS",70,0)
 D DG1^ORWDBA3($G(IFN),"I",I)
"RTN","ORMBLDPS",71,0)
 I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D
"RTN","ORMBLDPS",72,0)
 . S I=I+1 D ZRN(IFN,.ORMSG,I)
"RTN","ORMBLDPS",73,0)
 Q
"RTN","ORMBLDPS",74,0)
 ;
"RTN","ORMBLDPS",75,0)
INSTR() ; -- Return text instructions for QT-8, instance I
"RTN","ORMBLDPS",76,0)
 N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5)
"RTN","ORMBLDPS",77,0)
 I $G(ORDIALOG(DRUG,1)),$L(Y) Q $$ESC(Y)
"RTN","ORMBLDPS",78,0)
 S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D
"RTN","ORMBLDPS",79,0)
 . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I))
"RTN","ORMBLDPS",80,0)
 . S:$L(UNT) Y=Y_" "_UNT ;old format
"RTN","ORMBLDPS",81,0)
 Q $$ESC(Y)
"RTN","ORMBLDPS",82,0)
 ;
"RTN","ORMBLDPS",83,0)
HL7DUR() ; -- Returns HL7 form of duration X
"RTN","ORMBLDPS",84,0)
 N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I))
"RTN","ORMBLDPS",85,0)
 S X1=+$G(X),Y="" G:X1'>0 HDQ
"RTN","ORMBLDPS",86,0)
 S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99)
"RTN","ORMBLDPS",87,0)
 S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1
"RTN","ORMBLDPS",88,0)
HDQ Q Y
"RTN","ORMBLDPS",89,0)
 ;
"RTN","ORMBLDPS",90,0)
IV ; -- new IV Meds order
"RTN","ORMBLDPS",91,0)
 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST
"RTN","ORMBLDPS",92,0)
 N IVLIMIT ; duratioin or total volume for IV order
"RTN","ORMBLDPS",93,0)
 N IVTYPE,IVZRX,X,CNT,ROUTE,ORBCMA,DFN
"RTN","ORMBLDPS",94,0)
 S IVLIMIT=$$PTR("DURATION")
"RTN","ORMBLDPS",95,0)
 S IVTYPE=$G(ORDIALOG(+$$PTR("IV TYPE"),1))
"RTN","ORMBLDPS",96,0)
 I IVTYPE="",$P($G(^OR(100,IFN,3)),U,11)="B" D
"RTN","ORMBLDPS",97,0)
 .S IVTYPE=$$MOB^ORMBLDP1(IFN,+$P($G(^OR(100,IFN,0)),U,2))
"RTN","ORMBLDPS",98,0)
 .D RESP^ORCSAVE2(IFN,"OR GTX IV TYPE",IVTYPE)
"RTN","ORMBLDPS",99,0)
 S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE")
"RTN","ORMBLDPS",100,0)
 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
"RTN","ORMBLDPS",101,0)
 S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME")
"RTN","ORMBLDPS",102,0)
 S SCHTYPE=$$PTR("SCHEDULE TYPE")
"RTN","ORMBLDPS",103,0)
 S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1))
"RTN","ORMBLDPS",104,0)
 ;I IVTYPE="",$G(ORDIALOG(+$$PTR("SCHEDULE"),1))="" S IVTYPE="C"
"RTN","ORMBLDPS",105,0)
 I IVTYPE="I" S QT=U_$$ESC($G(ORDIALOG(+$$PTR("SCHEDULE"),1)))_"&"_$G(ORDIALOG(+$$PTR("ADMIN TIMES"),1))_"^^^^"
"RTN","ORMBLDPS",106,0)
 I IVTYPE="C" S QT="^^^^^"
"RTN","ORMBLDPS",107,0)
 ;S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^"
"RTN","ORMBLDPS",108,0)
 S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2)
"RTN","ORMBLDPS",109,0)
 S $P(ORMSG(4),"|",8)=QT
"RTN","ORMBLDPS",110,0)
 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different
"RTN","ORMBLDPS",111,0)
 S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_$$ESC(RATE) ;strip any trailing spaces
"RTN","ORMBLDPS",112,0)
 S IVLIMIT=$G(ORDIALOG(IVLIMIT,1))
"RTN","ORMBLDPS",113,0)
 I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT^ORMBLDP1(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE
"RTN","ORMBLDPS",114,0)
 S I=5 I $L($G(ORDIALOG(WP,1))) D
"RTN","ORMBLDPS",115,0)
 . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J
"RTN","ORMBLDPS",116,0)
 . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,WP,1,J,0)))
"RTN","ORMBLDPS",117,0)
 . S K=0 F  S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0  S K=K+1,ORMSG(6,K)=^(J,0)
"RTN","ORMBLDPS",118,0)
 ;S I=I+1,ORMSG(I)=$$RXR(+$$PTR("ROUTE"))
"RTN","ORMBLDPS",119,0)
 S ROUTE=+$$PTR("ROUTE")
"RTN","ORMBLDPS",120,0)
 S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,1)))
"RTN","ORMBLDPS",121,0)
IV1 S INST=0 F  S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0  D
"RTN","ORMBLDPS",122,0)
 . S X1="B",X2=+$G(ORDIALOG(SOLN,INST))
"RTN","ORMBLDPS",123,0)
 . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix
"RTN","ORMBLDPS",124,0)
 . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML")
"RTN","ORMBLDPS",125,0)
 I $O(ORDIALOG(ADDS,0)) D
"RTN","ORMBLDPS",126,0)
 . S INST=0 F  S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0  D
"RTN","ORMBLDPS",127,0)
 . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST))
"RTN","ORMBLDPS",128,0)
 . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2)
"RTN","ORMBLDPS",129,0)
 D ORDCHKS
"RTN","ORMBLDPS",130,0)
 S IVZRX=$$ZRX(IFN,0)
"RTN","ORMBLDPS",131,0)
 S CNT=0
"RTN","ORMBLDPS",132,0)
 F X=1:1:$L(IVZRX) I $E(IVZRX,X)="|" S CNT=CNT+1
"RTN","ORMBLDPS",133,0)
 I CNT<6 F X=CNT:1:5 S IVZRX=IVZRX_"|"
"RTN","ORMBLDPS",134,0)
 S I=I+1,ORMSG(I)=IVZRX_IVTYPE
"RTN","ORMBLDPS",135,0)
 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project
"RTN","ORMBLDPS",136,0)
 D DG1^ORWDBA3($G(IFN),"I",I)
"RTN","ORMBLDPS",137,0)
 Q
"RTN","ORMBLDPS",138,0)
 ;
"RTN","ORMBLDPS",139,0)
RXR(ROUTE) ; -- Returns RXR segment
"RTN","ORMBLDPS",140,0)
 N IEN,NAME
"RTN","ORMBLDPS",141,0)
 I +ROUTE=0 Q "RXR|^^^^^99PSR"
"RTN","ORMBLDPS",142,0)
 K ^TMP($J,"ORMBLDPS RXR")
"RTN","ORMBLDPS",143,0)
 D ALL^PSS51P2(+ROUTE,,,,"ORMBLDPS RXR")
"RTN","ORMBLDPS",144,0)
 S NAME=^TMP($J,"ORMBLDPS RXR",+ROUTE,.01)
"RTN","ORMBLDPS",145,0)
 ;N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01)
"RTN","ORMBLDPS",146,0)
 K ^TMP($J,"ORMBLDPS RXR")
"RTN","ORMBLDPS",147,0)
 Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR"
"RTN","ORMBLDPS",148,0)
 ;
"RTN","ORMBLDPS",149,0)
ZRX(IFN,OUTPT) ; -- Returns ZRX segment
"RTN","ORMBLDPS",150,0)
 N NATURE,TYPE,ORIG,PSORIG,ROUTING,ZRX
"RTN","ORMBLDPS",151,0)
 S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12)
"RTN","ORMBLDPS",152,0)
 S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code
"RTN","ORMBLDPS",153,0)
 S PSORIG="" I (TYPE=1)!(TYPE=2) D
"RTN","ORMBLDPS",154,0)
 . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4))
"RTN","ORMBLDPS",155,0)
 . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order
"RTN","ORMBLDPS",156,0)
 S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N")
"RTN","ORMBLDPS",157,0)
 S ROUTING=$G(ORDIALOG($$PTR("ROUTING"),1))
"RTN","ORMBLDPS",158,0)
 ;AGP FIX FOR PROBLEM WITH ROUTING BE SET TO DAY SUPPLY ONCE ROOT CAUSE
"RTN","ORMBLDPS",159,0)
 ;IS FOUND THIS CODE WILL BE REMOVE
"RTN","ORMBLDPS",160,0)
 I OUTPT=1,ROUTING'="",ROUTING>0 S ROUTING="M"
"RTN","ORMBLDPS",161,0)
 I $G(OUTPT) S ZRX=ZRX_"|"_ROUTING_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"")
"RTN","ORMBLDPS",162,0)
 Q ZRX
"RTN","ORMBLDPS",163,0)
 ;
"RTN","ORMBLDPS",164,0)
ZRN(IFN,ORMSG,I) ; -- Set ZRN segment
"RTN","ORMBLDPS",165,0)
 N ST,ZRN,J,K,TXT
"RTN","ORMBLDPS",166,0)
 S ORMSG(I)="ZRN|N|"
"RTN","ORMBLDPS",167,0)
 S ST=$$PTR("STATEMENTS")
"RTN","ORMBLDPS",168,0)
 I $L($G(ORDIALOG(ST,1))) D
"RTN","ORMBLDPS",169,0)
 . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J
"RTN","ORMBLDPS",170,0)
 . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0))
"RTN","ORMBLDPS",171,0)
 . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT
"RTN","ORMBLDPS",172,0)
 . F  S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0  S TXT=$G(^(J,0)) D
"RTN","ORMBLDPS",173,0)
 . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT
"RTN","ORMBLDPS",174,0)
 Q
"RTN","ORMBLDPS",175,0)
 ;
"RTN","ORMBLDPS",176,0)
ORDCHKS ; -- Include order checks in OBX segments
"RTN","ORMBLDPS",177,0)
 N ORRET,OC,CNT S CNT=0
"RTN","ORMBLDPS",178,0)
 D GETOC5^OROCAPI1(+IFN,"SIGNATURE_CPRS",.ORRET)
"RTN","ORMBLDPS",179,0)
 S OC=0 F  S OC=$O(ORRET(+IFN,"DATA",OC)) Q:'OC  D
"RTN","ORMBLDPS",180,0)
 .S I=I+1,CNT=CNT+1
"RTN","ORMBLDPS",181,0)
 .S ORMSG(I)="OBX|"_CNT_"|TX|^^^"_+ORRET(+IFN,"DATA",OC,1)_"^^99OCX||"_$$ESC($G(ORRET(+IFN,"DATA",OC,"OC",1,0)))_"|||||||||"_$$FMTHL7^XLFDT($P(ORRET(+IFN,"DATA",OC,1),U,5))_"||"_$P(ORRET(+IFN,"DATA",OC,1),U,5)
"RTN","ORMBLDPS",182,0)
 .I $L($G(ORRET(+IFN,"DATA",OC,"OR",1,0))) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$$ESC($G(ORRET(+IFN,"DATA",OC,"OR",1,0)))
"RTN","ORMBLDPS",183,0)
 Q
"RTN","ORMBLDPS",184,0)
 ;
"RTN","ORMBLDPS",185,0)
HL7UNIT(X) ; -- Return coded element for volume/strength units
"RTN","ORMBLDPS",186,0)
 N I,UNIT,Y
"RTN","ORMBLDPS",187,0)
 F I=1:1:$L(X) I $E(X,I)?1A Q  ; first letter
"RTN","ORMBLDPS",188,0)
 S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y=""
"RTN","ORMBLDPS",189,0)
 F I=1:1:14 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q
"RTN","ORMBLDPS",190,0)
 Q Y
"RTN","ORMBLDPS",191,0)
 ;
"RTN","ORMBLDPS",192,0)
VER(IFN) ; -- Send msg for nurse-verified orders
"RTN","ORMBLDPS",193,0)
 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I"  ;Inpt only
"RTN","ORMBLDPS",194,0)
 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2))
"RTN","ORMBLDPS",195,0)
 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10))
"RTN","ORMBLDPS",196,0)
 S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT)
"RTN","ORMBLDPS",197,0)
 D MSG^XQOR("OR EVSEND PS",.ORMSG)
"RTN","ORMBLDPS",198,0)
 Q
"RTN","ORMBLDPS",199,0)
 ;
"RTN","ORMBLDPS",200,0)
REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request
"RTN","ORMBLDPS",201,0)
 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O"
"RTN","ORMBLDPS",202,0)
 S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10))
"RTN","ORMBLDPS",203,0)
 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2))
"RTN","ORMBLDPS",204,0)
 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC)
"RTN","ORMBLDPS",205,0)
 S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT)
"RTN","ORMBLDPS",206,0)
 S ORMSG(5)="ZRX||||"_ROUTING
"RTN","ORMBLDPS",207,0)
 D MSG^XQOR("OR EVSEND PS",.ORMSG)
"RTN","ORMBLDPS",208,0)
 Q
"RTN","ORMBLDPS",209,0)
ESC(STR) ;
"RTN","ORMBLDPS",210,0)
 Q $$ESC^ORHLESC(STR,"~|\&^")
"RTN","OROCAPI1")
0^1^B44849780
"RTN","OROCAPI1",1,0)
OROCAPI1 ; JMH - ORDER CHECK INSTANCES File APIs;8/24/07 ;06/08/10  11:48
"RTN","OROCAPI1",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**293**;Dec 17, 1997;Build 20
"RTN","OROCAPI1",3,0)
SAVEOC(ORL,RET) ;SAVE A GROUP OF ORDER CHECKS
"RTN","OROCAPI1",4,0)
         ;ORL=LIST OF ORDER CHECKS
"RTN","OROCAPI1",5,0)
         ;(D0,1)=ORDER NUMBER (FILE 100)^
"RTN","OROCAPI1",6,0)
         ;       OCCURANCE DESCRIPTOR^
"RTN","OROCAPI1",7,0)
         ;       USER (FILE 200)^
"RTN","OROCAPI1",8,0)
         ;       OCCURANCE D/T^
"RTN","OROCAPI1",9,0)
         ;       ORDER CHECK NUMBER (FILE 100.8)^
"RTN","OROCAPI1",10,0)
         ;       CLINICAL DANGER LEVEL
"RTN","OROCAPI1",11,0)
         ;   (D0,2)=ORDER CHECK NARRATIVE
"RTN","OROCAPI1",12,0)
         ;   (D0,3)=OVERRIDE REASON
"RTN","OROCAPI1",13,0)
         ;RET=RETURN ARRAY OF IENS BY ORL(D0)
"RTN","OROCAPI1",14,0)
         ;    RET(D0,IEN)=""
"RTN","OROCAPI1",15,0)
         N I S I=0 F  S I=$O(ORL(I)) Q:'I  D
"RTN","OROCAPI1",16,0)
         .N DA,DR,DIC,X,Y,DIE,ORSTATUS,ORN,ORDANG,DW,DV,%,D,DC,DE,DH,DI,DIEL,DIFLD,DIP,DK,DM,DP,DQ
"RTN","OROCAPI1",17,0)
         .S ORN=+ORL(I,1)
"RTN","OROCAPI1",18,0)
         .Q:'ORN!('$D(^OR(100,ORN)))
"RTN","OROCAPI1",19,0)
         .Q:'$P(ORL(I,1),U,5)  ;QUIT IF NO ORDER CHECK NUMBER
"RTN","OROCAPI1",20,0)
         .Q:'$L($G(ORL(I,2)))  ;QUIT IF NO ORDER CHECK TEXT
"RTN","OROCAPI1",21,0)
         .S DIC="^ORD(100.05,",DIC(0)="F",X=ORN D FILE^DICN
"RTN","OROCAPI1",22,0)
         .Q:'DA
"RTN","OROCAPI1",23,0)
         .S RET(I,DA)=""
"RTN","OROCAPI1",24,0)
         .S DIE=DIC,ORSTATUS=$P($G(^OR(100,ORN,3)),U,3),ORDANG=$S($P($G(ORL(I,1)),U,6):$P($G(ORL(I,1)),U,6),1:$$GET^XPAR("ALL","ORK CLINICAL DANGER LEVEL",$P($G(ORL(I,1)),U,5),"I"))
"RTN","OROCAPI1",25,0)
         .S DR="1////"_ORSTATUS_";2////"_$P($G(ORL(I,1)),U,2)_";3////"_$P($G(ORL(I,1)),U,3)_";4////"_$P($G(ORL(I,1)),U,4)_";5////"_$P($G(ORL(I,1)),U,5)_";6////"_ORDANG_";8///"_$TR($G(ORL(I,2)),";",",")_";7///"_$TR($G(ORL(I,3)),";",",")
"RTN","OROCAPI1",26,0)
         .D ^DIE
"RTN","OROCAPI1",27,0)
         .;set ^ORD(100.05,DA,2) if ORL(DO,2,1) exists
"RTN","OROCAPI1",28,0)
         .I $D(ORL(I,2,1)) N J S J=0 F  S J=$O(ORL(I,2,J)) Q:'J  S ^ORD(100.05,DA,2,J+1,0)=ORL(I,2,J)
"RTN","OROCAPI1",29,0)
         Q
"RTN","OROCAPI1",30,0)
GETOC1(IEN,RET) ;GET A SINGLE ORDER CHECK
"RTN","OROCAPI1",31,0)
         ;IEN = 100.05 IEN
"RTN","OROCAPI1",32,0)
         ;RET = RETURNED 100.05 DATA FOR IEN
"RTN","OROCAPI1",33,0)
         K RET
"RTN","OROCAPI1",34,0)
         Q:'$G(IEN)
"RTN","OROCAPI1",35,0)
         Q:'$D(^ORD(100.05,IEN))
"RTN","OROCAPI1",36,0)
         S RET(IEN,0)=$G(^ORD(100.05,IEN,0))
"RTN","OROCAPI1",37,0)
         S RET(IEN,1)=$G(^ORD(100.05,IEN,1))
"RTN","OROCAPI1",38,0)
         M RET(IEN,"OC")=^ORD(100.05,IEN,2)
"RTN","OROCAPI1",39,0)
         K RET(IEN,"OC",0)
"RTN","OROCAPI1",40,0)
         M RET(IEN,"OR")=^ORD(100.05,IEN,3)
"RTN","OROCAPI1",41,0)
         K RET(IEN,"OR",0)
"RTN","OROCAPI1",42,0)
         Q
"RTN","OROCAPI1",43,0)
GETOC2(ORD,RET) ;GET ALL 100.05 IENS FOR A SPECIFIC ORDER
"RTN","OROCAPI1",44,0)
         ;ORD = 100 IEN
"RTN","OROCAPI1",45,0)
         ;RET = LIST OF 100.05 IENS
"RTN","OROCAPI1",46,0)
         K RET
"RTN","OROCAPI1",47,0)
         Q:'$G(ORD)
"RTN","OROCAPI1",48,0)
         N I S I=0 F  S I=$O(^ORD(100.05,"B",ORD,I)) Q:'I  S RET(ORD,I)=""
"RTN","OROCAPI1",49,0)
         Q
"RTN","OROCAPI1",50,0)
GETOC3(ORD,OCC,RET) ;GET ALL 100.05 IENS FOR A SPECIFIC ORDER/OCCURANCE PAIR
"RTN","OROCAPI1",51,0)
         ;ORD = 100 IEN
"RTN","OROCAPI1",52,0)
         ;OCC = OCCURANCE STRING
"RTN","OROCAPI1",53,0)
         ;RET = LIST OF 100.05 IENS
"RTN","OROCAPI1",54,0)
         K RET
"RTN","OROCAPI1",55,0)
         Q:'$G(ORD)
"RTN","OROCAPI1",56,0)
         Q:'$L(OCC)
"RTN","OROCAPI1",57,0)
         N I S I=0 F  S I=$O(^ORD(100.05,"C",ORD,OCC,I)) Q:'I  S RET(ORD,I)=""
"RTN","OROCAPI1",58,0)
         Q
"RTN","OROCAPI1",59,0)
GETOC4(ORD,RET) ;GET DATA FOR ALL 100.05 RECORDS OF A SPECIFIC ORDER
"RTN","OROCAPI1",60,0)
         ;ORD = 100 IEN
"RTN","OROCAPI1",61,0)
         ;RET = LIST OF 100.05 IENS
"RTN","OROCAPI1",62,0)
         K RET
"RTN","OROCAPI1",63,0)
         Q:'$G(ORD)
"RTN","OROCAPI1",64,0)
         N RET2
"RTN","OROCAPI1",65,0)
         D GETOC2(ORD,.RET)
"RTN","OROCAPI1",66,0)
         Q:'$D(RET)
"RTN","OROCAPI1",67,0)
         N I S I=0 F  S I=$O(RET(ORD,I)) Q:'I  D
"RTN","OROCAPI1",68,0)
         .D GETOC1(I,.RET2)
"RTN","OROCAPI1",69,0)
         .M RET(ORD,"DATA")=RET2
"RTN","OROCAPI1",70,0)
         Q
"RTN","OROCAPI1",71,0)
GETOC5(ORD,OCC,RET) ;GET DATA FOR ALL 100.05 RECORDS OF A SPECIFIC ORDER/OCCURANCE PAIR
"RTN","OROCAPI1",72,0)
         ;ORD = 100 IEN
"RTN","OROCAPI1",73,0)
         ;OCC = OCCURANCE STRING
"RTN","OROCAPI1",74,0)
         ;RET = LIST OF 100.05 IENS WITH DATA
"RTN","OROCAPI1",75,0)
         K RET
"RTN","OROCAPI1",76,0)
         Q:'$G(ORD)
"RTN","OROCAPI1",77,0)
         Q:'$L(OCC)
"RTN","OROCAPI1",78,0)
         N RET2
"RTN","OROCAPI1",79,0)
         D GETOC3(ORD,OCC,.RET)
"RTN","OROCAPI1",80,0)
         Q:'$D(RET)
"RTN","OROCAPI1",81,0)
         N I S I=0 F  S I=$O(RET(ORD,I)) Q:'I  D
"RTN","OROCAPI1",82,0)
         .D GETOC1(I,.RET2)
"RTN","OROCAPI1",83,0)
         .M RET(ORD,"DATA")=RET2
"RTN","OROCAPI1",84,0)
         Q
"RTN","OROCAPI1",85,0)
CONVERT ;CONVERT EXISTING FILE 100 NODE 9 ENTRIES OVER TO FILE 100.05
"RTN","OROCAPI1",86,0)
 N I,J,ORK,DESC
"RTN","OROCAPI1",87,0)
 S I=0
"RTN","OROCAPI1",88,0)
 I $G(^XTMP("ORK FILE CONVERSION")) S I=+^XTMP("ORK FILE CONVERSION")
"RTN","OROCAPI1",89,0)
 F  S I=$O(^OR(100,I)) Q:'I  I $D(^OR(100,I,9)) I '$D(^ORD(100.05,"B",I)) D CONVERT1(I)
"RTN","OROCAPI1",90,0)
 S I=0
"RTN","OROCAPI1",91,0)
 F  S I=$O(^XTMP("ORK FILE CONVERSION","ERRORS",I)) Q:'I  D DELETE(I)
"RTN","OROCAPI1",92,0)
 K ^XTMP("ORK FILE CONVERSION","LAST ERRORS")
"RTN","OROCAPI1",93,0)
 M ^XTMP("ORK FILE CONVERSION","LAST ERRORS")=^XTMP("ORK FILE CONVERSION","ERRORS")
"RTN","OROCAPI1",94,0)
 K ^XTMP("ORK FILE CONVERSION","ERRORS")
"RTN","OROCAPI1",95,0)
 S ^XTMP("ORK FILE CONVERSION")=0
"RTN","OROCAPI1",96,0)
 D MAIL
"RTN","OROCAPI1",97,0)
 Q
"RTN","OROCAPI1",98,0)
CONVERT1(I) ;CONVERT EXISTING FILE 100 NODE 9 ENTRIES OVER TO FILE 100.05 FOR 1 ORDER
"RTN","OROCAPI1",99,0)
 N $ETRAP,$ESTACK
"RTN","OROCAPI1",100,0)
 S $ETRAP="D ERR^OROCAPI1 Q"
"RTN","OROCAPI1",101,0)
 N J,ORK,DESC,RET
"RTN","OROCAPI1",102,0)
 S DESC="SIGNATURE_CPRS"
"RTN","OROCAPI1",103,0)
 S ^XTMP("ORK FILE CONVERSION",0)=$$FMADD^XLFDT($$NOW^XLFDT,90)_U_$$NOW^XLFDT
"RTN","OROCAPI1",104,0)
 I ",11,13,14,"[(","_$P($G(^OR(100,I,3)),U,3)_",") S DESC="ACCEPTANCE_CPRS"
"RTN","OROCAPI1",105,0)
 S J=0 F  S J=$O(^OR(100,I,9,J)) Q:'J  D
"RTN","OROCAPI1",106,0)
 .N X0,X1 S X0=$G(^OR(100,I,9,J,0)),X1=$G(^OR(100,I,9,J,1))
"RTN","OROCAPI1",107,0)
 .N ORKDT S ORKDT=$S($P(X0,U,6):$P(X0,U,6),1:$P($G(^OR(100,I,0)),U,7))
"RTN","OROCAPI1",108,0)
 .S ORK(J,1)=I_U_DESC_U_$P(X0,U,5)_U_ORKDT_U_$P(X0,U)
"RTN","OROCAPI1",109,0)
 .S ORK(J,2)=X1
"RTN","OROCAPI1",110,0)
 .S ORK(J,3)=$P(X0,U,4)
"RTN","OROCAPI1",111,0)
 I $D(ORK) D SAVEOC^OROCAPI1(.ORK,.RET)
"RTN","OROCAPI1",112,0)
 S ^XTMP("ORK FILE CONVERSION")=I
"RTN","OROCAPI1",113,0)
 Q
"RTN","OROCAPI1",114,0)
COPY(ORD1,ORD2) ;COPY THE ORDER CHECKS FROM ORDER 1 TO ORDER 2
"RTN","OROCAPI1",115,0)
 N RET,ORK,I
"RTN","OROCAPI1",116,0)
 D GETOC4(ORD1,.RET) S I=0 F  S I=$O(RET(ORD1,"DATA",I)) Q:'I  D
"RTN","OROCAPI1",117,0)
 .S ORK(I,1)=ORD2_U_$P($G(RET(ORD1,"DATA",I,0)),U,3)_U_$P($G(RET(ORD1,"DATA",I,0)),U,4)_U_$P($G(RET(ORD1,"DATA",I,0)),U,5)_U_$P($G(RET(ORD1,"DATA",I,1)),U,1)
"RTN","OROCAPI1",118,0)
 .S ORK(I,2)=$G(RET(ORD1,"DATA",I,"OC",1,0))
"RTN","OROCAPI1",119,0)
 .S ORK(I,3)=$G(RET(ORD1,"DATA",I,"OR",1,0))
"RTN","OROCAPI1",120,0)
 D SAVEOC(.ORK)
"RTN","OROCAPI1",121,0)
 Q
"RTN","OROCAPI1",122,0)
OCCNT(ORD) ;RETURN 1 IF THERE ARE ORDER CHECKS AND 0 IF NOT
"RTN","OROCAPI1",123,0)
 N RET,Y D GETOC2(ORD,.RET)
"RTN","OROCAPI1",124,0)
 S Y=0 I $D(RET) S Y=1
"RTN","OROCAPI1",125,0)
 Q Y
"RTN","OROCAPI1",126,0)
DELETE(ORD) ;DELETE ALL OF THE OC INSTANCES FOR AN ORDER
"RTN","OROCAPI1",127,0)
 N RET,I,DIK,DA D GETOC2(ORD,.RET)
"RTN","OROCAPI1",128,0)
 S I=0 F  S I=$O(RET(ORD,I)) Q:'I  S DA=I,DIK="^ORD(100.05," D ^DIK
"RTN","OROCAPI1",129,0)
 Q
"RTN","OROCAPI1",130,0)
DELOCC(ORD,OCC) ;DELETE ALL OF THE OC INSTANCES FOR AN ORDER/OCCURANCE PAIR
"RTN","OROCAPI1",131,0)
 N RET,I,DIK,DA D GETOC3(ORD,OCC,.RET)
"RTN","OROCAPI1",132,0)
 S I=0 F  S I=$O(RET(ORD,I)) Q:'I  S DA=I,DIK="^ORD(100.05," D ^DIK
"RTN","OROCAPI1",133,0)
 Q
"RTN","OROCAPI1",134,0)
ERR ;
"RTN","OROCAPI1",135,0)
 S ^XTMP("ORK FILE CONVERSION","ERRORS",ORN)=""
"RTN","OROCAPI1",136,0)
 S ^XTMP("ORK FILE CONVERSION")=ORN
"RTN","OROCAPI1",137,0)
 D UNWIND^%ZTER
"RTN","OROCAPI1",138,0)
 Q
"RTN","OROCAPI1",139,0)
MAIL ;send mail message to installer if any errors encountered during conversion process
"RTN","OROCAPI1",140,0)
 Q:'$D(^XTMP("ORK FILE CONVERSION","LAST ERRORS"))
"RTN","OROCAPI1",141,0)
 N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,ORTXT,I,J
"RTN","OROCAPI1",142,0)
 S XMDUZ="PATCH OR*3*293 ORDER CHECK CONVERSION" S:$G(DUZ) XMY(^XTMP("ORK FILE CONVERSION","INSTALLER"))=""
"RTN","OROCAPI1",143,0)
 S I=0,I=I+1,^TMP($J,"ORTXT",I)=""
"RTN","OROCAPI1",144,0)
 S I=I+1,^TMP($J,"ORTXT",I)="While converting order check information from file 100 node 9 over to file"
"RTN","OROCAPI1",145,0)
 S I=I+1,^TMP($J,"ORTXT",I)="100.05, data errors were discovered for the order numbers listed below."
"RTN","OROCAPI1",146,0)
 S I=I+1,^TMP($J,"ORTXT",I)="All other order data converted appropriately."
"RTN","OROCAPI1",147,0)
 S I=I+1,^TMP($J,"ORTXT",I)="We recommend correcting the data, and then re-running the"
"RTN","OROCAPI1",148,0)
 S I=I+1,^TMP($J,"ORTXT",I)="conversion utility from programmer prompt as follows:"
"RTN","OROCAPI1",149,0)
 S I=I+1,^TMP($J,"ORTXT",I)="    D CONVERT^OROCAPI1"
"RTN","OROCAPI1",150,0)
 S I=I+1,^TMP($J,"ORTXT",I)="NOTE: re-running the conversion utility will only convert those orders that"
"RTN","OROCAPI1",151,0)
 S I=I+1,^TMP($J,"ORTXT",I)="did not convert properly the first time."
"RTN","OROCAPI1",152,0)
 S I=I+1,^TMP($J,"ORTXT",I)=""
"RTN","OROCAPI1",153,0)
 S I=I+1,^TMP($J,"ORTXT",I)="LIST OF ORDERS WITH CORRUPTED ORDER CHECK DATA"
"RTN","OROCAPI1",154,0)
 S I=I+1,^TMP($J,"ORTXT",I)="=============================================="
"RTN","OROCAPI1",155,0)
 S J=0 F  S J=$O(^XTMP("ORK FILE CONVERSION","LAST ERRORS",J)) Q:'J  S I=I+1,^TMP($J,"ORTXT",I)=J
"RTN","OROCAPI1",156,0)
 S XMTEXT="^TMP($J,""ORTXT"",",XMSUB="PATCH OR*3*293 CONVERSION ERRORS!"
"RTN","OROCAPI1",157,0)
 D ^XMD
"RTN","OROCAPI1",158,0)
 Q
"RTN","ORQ2")
0^6^B46973301
"RTN","ORQ2",1,0)
ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;9/28/2009 15:00
"RTN","ORQ2",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195,243,282,293**;Dec 17, 1997;Build 20
"RTN","ORQ2",3,0)
 ;
"RTN","ORQ2",4,0)
 ;
"RTN","ORQ2",5,0)
 ;Reference to ^DIC(45.7 supported by IA #519
"RTN","ORQ2",6,0)
 ;Reference to OERR^VADPT supported by IA #4325
"RTN","ORQ2",7,0)
 ;
"RTN","ORQ2",8,0)
DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#)
"RTN","ORQ2",9,0)
 N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT
"RTN","ORQ2",10,0)
 S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6))
"RTN","ORQ2",11,0)
 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
"RTN","ORQ2",12,0)
 K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx
"RTN","ORQ2",13,0)
 M @ORY=ORYT ;Move text to global
"RTN","ORQ2",14,0)
 S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0  D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF)
"RTN","ORQ2",15,0)
 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
"RTN","ORQ2",16,0)
D1 I $O(^OR(100,+ORIFN,2,0)) D
"RTN","ORQ2",17,0)
 . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:"
"RTN","ORQ2",18,0)
 . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF)
"RTN","ORQ2",19,0)
 . N IFN S IFN=0
"RTN","ORQ2",20,0)
 . F  S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1  I $D(^OR(100,IFN,0)) D SUB(IFN)
"RTN","ORQ2",21,0)
 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank
"RTN","ORQ2",22,0)
 I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D
"RTN","ORQ2",23,0)
 . S CNT=CNT+1,@ORY@(CNT)="Parent Order:"
"RTN","ORQ2",24,0)
 . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF)
"RTN","ORQ2",25,0)
 . D SUB(+$P(OR3,U,9))
"RTN","ORQ2",26,0)
 . S CNT=CNT+1,@ORY@(CNT)="   " ;blank
"RTN","ORQ2",27,0)
 I $P(OR3,U,11)=1,$P(OR3,U,5) D  ;Changed - show previous order
"RTN","ORQ2",28,0)
 . S CNT=CNT+1,@ORY@(CNT)="Previous Order:"
"RTN","ORQ2",29,0)
 . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text
"RTN","ORQ2",30,0)
 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55)
"RTN","ORQ2",31,0)
 . S CNT=CNT+1,@ORY@(CNT)="     Order Text:        "_$G(ORZ(1))
"RTN","ORQ2",32,0)
 . S I=1 F  S I=$O(ORZ(I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I))
"RTN","ORQ2",33,0)
D2 S CNT=CNT+1,@ORY@(CNT)="Activity:"
"RTN","ORQ2",34,0)
 D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF)
"RTN","ORQ2",35,0)
 S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W")
"RTN","ORQ2",36,0)
 F  S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0  S ACTION=$G(^(ORI,0)) D ACT^ORQ20
"RTN","ORQ2",37,0)
 I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20
"RTN","ORQ2",38,0)
 I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_"  Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"")
"RTN","ORQ2",39,0)
 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
"RTN","ORQ2",40,0)
D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:"
"RTN","ORQ2",41,0)
 D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)
"RTN","ORQ2",42,0)
 D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider:     "_$P(VAIN(2),"^",2)
"RTN","ORQ2",43,0)
 I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician:  "_$P(VAIN(11),"^",2)
"RTN","ORQ2",44,0)
 S CNT=CNT+1,@ORY@(CNT)="Treating Specialty:           "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U)
"RTN","ORQ2",45,0)
 S CNT=CNT+1,@ORY@(CNT)="Ordering Location:            "_$P($G(^SC(+$P(OR0,U,10),0)),U)
"RTN","ORQ2",46,0)
 S CNT=CNT+1,@ORY@(CNT)="Start Date/Time:              "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"")
"RTN","ORQ2",47,0)
 I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")"
"RTN","ORQ2",48,0)
 S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time:               "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"")
"RTN","ORQ2",49,0)
 I $P(OR3,U,3)=1,$P(OR6,U,6) S @ORY@(CNT)=@ORY@(CNT)_"  (expired "_$$DATE^ORQ20($P(OR6,U,6))_")"
"RTN","ORQ2",50,0)
 S CNT=CNT+1,@ORY@(CNT)="Current Status:               "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-")
"RTN","ORQ2",51,0)
 I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F  S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1  S CNT=CNT+1,@ORY@(CNT)="  "_^(J,0)
"RTN","ORQ2",52,0)
 S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN
"RTN","ORQ2",53,0)
 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
"RTN","ORQ2",54,0)
D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF)
"RTN","ORQ2",55,0)
 I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q
"RTN","ORQ2",56,0)
 S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101,"  ; 2.5 order
"RTN","ORQ2",57,0)
 D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN)
"RTN","ORQ2",58,0)
 S DIWL=1,DIWR=50,DIWF="C50"
"RTN","ORQ2",59,0)
 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0  S DA=0 F  S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA  D
"RTN","ORQ2",60,0)
 . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11)  ; child
"RTN","ORQ2",61,0)
 . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*"  ;hide
"RTN","ORQ2",62,0)
 . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST  ; no values
"RTN","ORQ2",63,0)
 . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A"))
"RTN","ORQ2",64,0)
 . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))
"RTN","ORQ2",65,0)
 . S INST=0 F  S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0  D
"RTN","ORQ2",66,0)
 . . I $E(ORDIALOG(PRMT,0))="W" D WP Q
"RTN","ORQ2",67,0)
 . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) I TITLE["Infusion Rate"&(X'="")&(X'["ml/hr") S TITLE="Infuse Over Time:",TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE))
"RTN","ORQ2",68,0)
 . . D ^DIWP
"RTN","ORQ2",69,0)
 . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT)
"RTN","ORQ2",70,0)
 . . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0)
"RTN","ORQ2",71,0)
 I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.:                  "_+^(4)
"RTN","ORQ2",72,0)
 S CNT=CNT+1,@ORY@(CNT)="   " ;blank
"RTN","ORQ2",73,0)
 D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data
"RTN","ORQ2",74,0)
 D BA^ORQ21 ;call for CIDC data
"RTN","ORQ2",75,0)
D5 K ^TMP($J,"OCDATA") I $$OCAPI^ORCHECK(+ORIFN,"OCDATA") D
"RTN","ORQ2",76,0)
 . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:"
"RTN","ORQ2",77,0)
 . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF)
"RTN","ORQ2",78,0)
 . S CK=0 F  S CK=$O(^TMP($J,"OCDATA",CK)) Q:CK'>0  D
"RTN","ORQ2",79,0)
 .. S X0=^TMP($J,"OCDATA",CK,"OC NUMBER")_U_^TMP($J,"OCDATA",CK,"OC LEVEL")_U_U_^TMP($J,"OCDATA",CK,"OR REASON")_U_^TMP($J,"OCDATA",CK,"OR PROVIDER")_U_^TMP($J,"OCDATA",CK,"OR DT")
"RTN","ORQ2",80,0)
 .. S X=^TMP($J,"OCDATA",CK,"OC TEXT",1,0)
"RTN","ORQ2",81,0)
 .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6)
"RTN","ORQ2",82,0)
 .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q
"RTN","ORQ2",83,0)
 .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP
"RTN","ORQ2",84,0)
 .. S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL="            "
"RTN","ORQ2",85,0)
 . K ^TMP($J,"OCDATA")
"RTN","ORQ2",86,0)
 . Q:'$L($G(OK))  S CNT=CNT+1,@ORY@(CNT)="Override:   "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3))
"RTN","ORQ2",87,0)
 . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)="            "_$P(OK,U) Q
"RTN","ORQ2",88,0)
 . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP
"RTN","ORQ2",89,0)
 . S I=0 F  S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0  S CNT=CNT+1,@ORY@(CNT)="            "_^(I,0)
"RTN","ORQ2",90,0)
 K ^TMP("ORWORD",$J),^UTILITY($J,"W")
"RTN","ORQ2",91,0)
 Q
"RTN","ORQ2",92,0)
 ;
"RTN","ORQ2",93,0)
SUB(IFN) ; -- add suborder or parent
"RTN","ORQ2",94,0)
 N ORCY,STS,STRT,IG,A,STOP,SCHED D TEXT^ORQ12(.ORCY,IFN,58)
"RTN","ORQ2",95,0)
 S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1))
"RTN","ORQ2",96,0)
 S A=^OR(100,IFN,0),STRT=$P(A,U,8),STOP=$P(A,U,9)
"RTN","ORQ2",97,0)
 S SCHED=$$VALUE^ORX8(IFN,"SCHEDULE",1,"E")
"RTN","ORQ2",98,0)
 S:STRT'="" STRT=$$DATE^ORQ20(STRT) I ORNMSP="LR" S:STOP]"" STOP=$$DATE^ORQ20(STOP)
"RTN","ORQ2",99,0)
 S IG=0 F  S IG=$O(ORCY(IG)) Q:IG<1  S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" "
"RTN","ORQ2",100,0)
 I ORNMSP="LR",STOP]"" S CNT=CNT+1,@ORY@(CNT)=$J("How often: ",16)_SCHED_"   Stops:  "_STOP
"RTN","ORQ2",101,0)
 Q
"RTN","ORQ2",102,0)
 ;
"RTN","ORQ2",103,0)
WP ; -- add word-processing
"RTN","ORQ2",104,0)
 N WP,ORI,X M WP=@ORDIALOG(PRMT,INST)
"RTN","ORQ2",105,0)
 S CNT=CNT+1,@ORY@(CNT)=TITLE
"RTN","ORQ2",106,0)
 S ORI=0 F  S ORI=$O(WP(ORI)) Q:ORI'>0  S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)="  "_X
"RTN","ORQ2",107,0)
 Q
"RTN","ORQ2",108,0)
 ;
"RTN","ORQ2",109,0)
CHILDREN(PARENT) ; -- add children
"RTN","ORQ2",110,0)
 N SEQ,DA,ITM,PRMT,TYPE,X
"RTN","ORQ2",111,0)
 S SEQ=0 F  S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0  S DA=$O(^(SEQ,0)) D
"RTN","ORQ2",112,0)
 . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2)
"RTN","ORQ2",113,0)
 . Q:$G(ORDIALOG(PRMT,INST))=""  Q:$P(ITM,U,9)["*"  ;no value or hide
"RTN","ORQ2",114,0)
 . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP
"RTN","ORQ2",115,0)
 . I TYPE'="W" D
"RTN","ORQ2",116,0)
 . . S X=$$EXT^ORCD(PRMT,INST)
"RTN","ORQ2",117,0)
 . . I $L(X,"|")=2 S X=$$REPLACE^ORHLESC(X,"|","||")
"RTN","ORQ2",118,0)
 . . D ^DIWP
"RTN","ORQ2",119,0)
 Q
"RTN","ORQ2",120,0)
 ;
"RTN","ORQ2",121,0)
SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes
"RTN","ORQ2",122,0)
 S ORY("VIDEO",LINE,COL,WIDTH)=ON
"RTN","ORQ2",123,0)
 S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF
"RTN","ORQ2",124,0)
 Q
"RTN","ORQ2",125,0)
 ;
"RTN","ORQ2",126,0)
VA ; -- Call VADPT
"RTN","ORQ2",127,0)
 N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT
"RTN","ORQ2",128,0)
 Q
"RTN","ORQ2",129,0)
 ;
"RTN","ORQ2",130,0)
CDL(X) ; -- Returns Clinical Danger Level X
"RTN","ORQ2",131,0)
 N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:")
"RTN","ORQ2",132,0)
 S Y=$E(Y_"        ",1,12)
"RTN","ORQ2",133,0)
 Q Y
"RTN","ORQ2",134,0)
 ;
"RTN","ORQ2",135,0)
ORIG(IFN) ; -- Return original start date of [renewal] order
"RTN","ORQ2",136,0)
 N I,Y,X3,DONE
"RTN","ORQ2",137,0)
 S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0
"RTN","ORQ2",138,0)
 F  S X3=$G(^OR(100,I,3)) D  Q:DONE
"RTN","ORQ2",139,0)
 . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q  ;loop
"RTN","ORQ2",140,0)
 . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1
"RTN","ORQ2",141,0)
 Q Y
"RTN","ORSRCHOR")
0^7^B81351241
"RTN","ORSRCHOR",1,0)
ORSRCHOR ;SLC/TC - Search Utility for Order Check Override Reason Report; 09/28/2009 15:00 ;09/16/10  20:05
"RTN","ORSRCHOR",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,293**;Dec 17, 1997;Build 20
"RTN","ORSRCHOR",3,0)
 ;
"RTN","ORSRCHOR",4,0)
 ;
"RTN","ORSRCHOR",5,0)
ASKUSER(ANS,DIR,ORQUIT) ; Controls prompting of the report utility.
"RTN","ORSRCHOR",6,0)
 ;
"RTN","ORSRCHOR",7,0)
 I $G(ANS("EXIT"))="YES" Q
"RTN","ORSRCHOR",8,0)
 S ANS("EXIT")="NO"
"RTN","ORSRCHOR",9,0)
 N DIRUT,POP,X,Y
"RTN","ORSRCHOR",10,0)
 S DIR(0)="S^1:DATE/TIME ORDERED & OVERRIDDEN BY;2:DATE/TIME ORDERED & ORDER CHECK;3:DATE/TIME ORDERED & DIVISION;4:DATE/TIME ORDERED & DISPLAY GROUP;5:DATE/TIME ORDERED, DIVISION, & DISPLAY GROUP",DIR("A")=DIR,DIR("B")="1"
"RTN","ORSRCHOR",11,0)
 D ^DIR I $D(DIRUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",12,0)
 N ORRSPNSE S ORRSPNSE=Y K DIR
"RTN","ORSRCHOR",13,0)
 N %DT,CNT,Y,DUOUT,DTOUT
"RTN","ORSRCHOR",14,0)
 S %DT="AE" F CNT=1:1:2 D
"RTN","ORSRCHOR",15,0)
 . S %DT("A")=$S(CNT=1:"SEARCH Orders Beginning: ",CNT=2:$J("Thru: ",25)),%DT("B")=$S(CNT=1:"",CNT=2:$P($$HTE^XLFDT($H),"@"))
"RTN","ORSRCHOR",16,0)
 . D ^%DT I Y=-1 S CNT=2 Q
"RTN","ORSRCHOR",17,0)
 . E  D
"RTN","ORSRCHOR",18,0)
 . . I CNT=1 S TMP("STRDT")=$P(Y,".")
"RTN","ORSRCHOR",19,0)
 . . I CNT=2 S TMP("ENDDT")=$P(Y,".")_".24"
"RTN","ORSRCHOR",20,0)
 I '$D(TMP("STRDT"))!'$D(TMP("ENDDT"))!$D(DTOUT)!$D(DUOUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",21,0)
 I ORRSPNSE=1 D  ; filter search by OVERRIDDEN BY field
"RTN","ORSRCHOR",22,0)
 . N DIC,Y,DTOUT,DUOUT S DIC="^VA(200,",DIC(0)="QEAMZ",DIC("A")="SEARCH Order Chks Overridden By: " D ^DIC I (Y=-1)!$D(DTOUT)!$D(DUOUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",23,0)
 . S ANS("SORT")="OVRDNBY",TMP("OVRBYIEN")=+Y,TMP("OVRBY")=Y(0,0)
"RTN","ORSRCHOR",24,0)
 I ORRSPNSE=2 D  ; filter search by ORDER CHK
"RTN","ORSRCHOR",25,0)
 . N DIC,Y,DTOUT,DUOUT S DIC="^ORD(100.8,",DIC(0)="QEAMZ" D ^DIC I (Y=-1)!$D(DTOUT)!$D(DUOUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",26,0)
 . S ANS("SORT")="ORCHK",TMP("ORCHKIEN")=+Y,TMP("ORCHK")=Y(0,0)
"RTN","ORSRCHOR",27,0)
 I ORRSPNSE=3 D  ; filter search by DIUISION
"RTN","ORSRCHOR",28,0)
 . N DIC,Y,DTOUT,DUOUT S DIC="^DG(40.8,",DIC(0)="QEAMZ" D ^DIC I (Y=-1)!$D(DTOUT)!$D(DUOUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",29,0)
 . S ANS("SORT")="DIV",TMP("ORDIVIEN")=+Y,TMP("ORDIV")=Y(0,0)
"RTN","ORSRCHOR",30,0)
 I ORRSPNSE=4 D  ; filter search by DISPLAY GROUP
"RTN","ORSRCHOR",31,0)
 . N DIC,Y,DTOUT,DUOUT S DIC="^ORD(100.98,",DIC(0)="QEAMZ" D ^DIC I (Y=-1)!$D(DTOUT)!$D(DUOUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",32,0)
 . S ANS("SORT")="DSPGRP",TMP("ORDGPIEN")=+Y,TMP("ORDSPGRP")=Y(0,0)
"RTN","ORSRCHOR",33,0)
 I ORRSPNSE=5 D  ; filter search by DIVISION & DISPLAY GROUP
"RTN","ORSRCHOR",34,0)
 . N DIC,CNT,Y,DTOUT,DUOUT S DIC(0)="QEAMZ",ANS("SORT")="DTORD"
"RTN","ORSRCHOR",35,0)
 . F CNT=1:1:2 D
"RTN","ORSRCHOR",36,0)
 . . S DIC=$S(CNT=1:"^DG(40.8,",CNT=2:"^ORD(100.98,")
"RTN","ORSRCHOR",37,0)
 . . D ^DIC I Y=-1 S CNT=2 Q
"RTN","ORSRCHOR",38,0)
 . . E  D
"RTN","ORSRCHOR",39,0)
 . . . I CNT=1 S TMP("ORDIVIEN")=+Y,TMP("ORDIV")=Y(0,0)
"RTN","ORSRCHOR",40,0)
 . . . I CNT=2 S TMP("ORDGPIEN")=+Y,TMP("ORDSPGRP")=Y(0,0)
"RTN","ORSRCHOR",41,0)
 . I '$D(TMP("ORDIVIEN"))!'$D(TMP("ORDGPIEN"))!$D(DTOUT)!$D(DUOUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",42,0)
 I ANS("EXIT")="NO" D
"RTN","ORSRCHOR",43,0)
 . N DIR,DIRUT,POP,X,Y S DIR(0)="Y",DIR("A")="Print delimited output only",DIR("B")="NO"
"RTN","ORSRCHOR",44,0)
 . S DIR("?",1)="Entering 'YES' will allow the user to specify a delimiter character",DIR("?",2)="and create a delimited report.",DIR("?",3)=""
"RTN","ORSRCHOR",45,0)
 . S DIR("?")="Entering 'NO' will create a regular summary report."
"RTN","ORSRCHOR",46,0)
 . D ^DIR I $D(DIRUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",47,0)
 . S ANS("DELIMIT")=Y(0) I ANS("DELIMIT")="YES" D
"RTN","ORSRCHOR",48,0)
 . . N DIR,DIRUT,X,Y S DIR("A")="Specify REPORT DELIMITER CHARACTER",DIR("B")="U"
"RTN","ORSRCHOR",49,0)
 . . S DIR(0)="S^P:Pipe;T:Tilde;U:Up arrow"
"RTN","ORSRCHOR",50,0)
 . . D ^DIR I $D(DIRUT) S ANS("EXIT")="YES" Q
"RTN","ORSRCHOR",51,0)
 . . S ANS("DELIMITER")=Y K DIR
"RTN","ORSRCHOR",52,0)
 . W !,"Searching....." D SRCHBYDT(TMP("STRDT"),TMP("ENDDT"))
"RTN","ORSRCHOR",53,0)
 Q
"RTN","ORSRCHOR",54,0)
 ;
"RTN","ORSRCHOR",55,0)
SRCHBYDT(STRDT,ENDDT) ; Search by Date/Time Ordered and sort by Date/Time Ordered, Division, Display Group, or Order Chk.
"RTN","ORSRCHOR",56,0)
 ;
"RTN","ORSRCHOR",57,0)
 N AFGLB,ORDNO,ORDACT
"RTN","ORSRCHOR",58,0)
 K ^TMP("OROVRRPT",$J) ; Ensures a fresh start
"RTN","ORSRCHOR",59,0)
 S AFGLB=$NA(^OR(100,"AF")),TMP=$NA(^TMP("OROVRRPT",$J))
"RTN","ORSRCHOR",60,0)
 S (ORDNO,ORDACT)=0
"RTN","ORSRCHOR",61,0)
 I (ANS("SORT")="OVRDNBY") S (TMP("ORCHKIEN"),TMP("ORDIVIEN"),TMP("ORDGPIEN"))=""
"RTN","ORSRCHOR",62,0)
 I (ANS("SORT")="ORCHK") S (TMP("OVRBYIEN"),TMP("ORDIVIEN"),TMP("ORDGPIEN"))=""
"RTN","ORSRCHOR",63,0)
 I (ANS("SORT")="DIV") S (TMP("ORCHKIEN"),TMP("OVRBYIEN"),TMP("ORDGPIEN"))=""
"RTN","ORSRCHOR",64,0)
 I (ANS("SORT")="DSPGRP") S (TMP("ORCHKIEN"),TMP("ORDIVIEN"),TMP("OVRBYIEN"))=""
"RTN","ORSRCHOR",65,0)
 I (ANS("SORT")="DTORD") S (TMP("ORCHKIEN"),TMP("OVRBYIEN"))=""
"RTN","ORSRCHOR",66,0)
 F  S STRDT=$O(@AFGLB@(STRDT)) Q:'+STRDT!(STRDT>ENDDT)  F  S ORDNO=$O(@AFGLB@(STRDT,ORDNO)) Q:'+ORDNO  F  S ORDACT=$O(@AFGLB@(STRDT,ORDNO,ORDACT)) Q:'+ORDACT  D
"RTN","ORSRCHOR",67,0)
 . K ^TMP($J,"OROCDATA") D OCAPI^ORCHECK(ORDNO,"OROCDATA")
"RTN","ORSRCHOR",68,0)
 . I (ORDACT=1)&($$OCCNT^OROCAPI1(ORDNO))&($L($G(^TMP($J,"OROCDATA",1,"OR REASON")))>0)  D
"RTN","ORSRCHOR",69,0)
 . . N ORD0,ORD8,ORD9,ORD91,ORDCHK S ORD0=$G(^OR(100,ORDNO,0)),ORD8=$G(^OR(100,ORDNO,8,1,.1,1,0))
"RTN","ORSRCHOR",70,0)
 . . S ORD9=$G(^TMP($J,"OROCDATA",1,"OC NUMBER"))_U_$G(^TMP($J,"OROCDATA",1,"OC LEVEL"))_U_U_$G(^TMP($J,"OROCDATA",1,"OR REASON"))_U_$G(^TMP($J,"OROCDATA",1,"OR PROVIDER"))_U_$G(^TMP($J,"OROCDATA",1,"OR DT"))
"RTN","ORSRCHOR",71,0)
 . . S ORD91=$G(^TMP($J,"OROCDATA",1,"OC TEXT",1,0))
"RTN","ORSRCHOR",72,0)
 . . S ORDCHK=$G(^ORD(100.8,$P(ORD9,U),0))_": "_ORD91
"RTN","ORSRCHOR",73,0)
 . . N PTLOC,DIVIEN,DIVISN,ORDLG,DSPGRIEN,DSPGRP S PTLOC=$P(ORD0,U,10),ORDLG=$P(ORD0,U,5)
"RTN","ORSRCHOR",74,0)
 . . I $D(PTLOC)&($P(PTLOC,";",2)="SC(")&($D(^SC(+PTLOC,0)))  S DIVIEN=$P($G(^SC(+PTLOC,0)),U,15),DIVISN=$P($G(^DG(40.8,DIVIEN,0)),U)  ;DBIA #10040
"RTN","ORSRCHOR",75,0)
 . . E  S DIVISN="NONE SPECIFIED"
"RTN","ORSRCHOR",76,0)
 . . I $D(ORDLG)&($P(ORDLG,";",2)="ORD(101.41,")&($D(^ORD(101.41,+ORDLG,0)))  S DSPGRIEN=$P($G(^ORD(101.41,+ORDLG,0)),U,5),DSPGRP=$P($G(^ORD(100.98,DSPGRIEN,0)),U)
"RTN","ORSRCHOR",77,0)
 . . E  S DSPGRP="NONE SPECIFIED"
"RTN","ORSRCHOR",78,0)
 . . N ORDCHK1,ORDCHK2 I $L(ORDCHK)>255 S ORDCHK1=$E(ORDCHK,1,255),ORDCHK2=$E(ORDCHK,256,$L(ORDCHK))
"RTN","ORSRCHOR",79,0)
 . . I (ANS("SORT")="OVRDNBY")&($P(ORD9,U,5)=TMP("OVRBYIEN"))  D
"RTN","ORSRCHOR",80,0)
 . . . I $L(ORDCHK)>255 S @TMP@(STRDT,DIVISN,DSPGRP,ORDCHK1,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_TMP("OVRBY")_U_$P(ORD9,U,6)_U_ORDCHK2
"RTN","ORSRCHOR",81,0)
 . . . E  S @TMP@(STRDT,DIVISN,DSPGRP,ORDCHK,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_TMP("OVRBY")_U_$P(ORD9,U,6)
"RTN","ORSRCHOR",82,0)
 . . I (ANS("SORT")="ORCHK")&($P(ORD9,U)=TMP("ORCHKIEN"))  D
"RTN","ORSRCHOR",83,0)
 . . . N ORCHCK1,ORCHCK2 I $L(ORD91)>255 D
"RTN","ORSRCHOR",84,0)
 . . . . S ORCHCK1=$E(ORD91,1,255),ORCHCK2=$E(ORD91,256,$L(ORD91)),@TMP@(ORCHCK1,DIVISN,DSPGRP,STRDT,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)_U_ORCHCK2
"RTN","ORSRCHOR",85,0)
 . . . E  S @TMP@(ORD91,DIVISN,DSPGRP,STRDT,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)
"RTN","ORSRCHOR",86,0)
 . . I (ANS("SORT")="DIV")&($P($G(^SC(+$P($G(^OR(100,ORDNO,0)),U,10),0)),U,15)=TMP("ORDIVIEN"))  D
"RTN","ORSRCHOR",87,0)
 . . . I $L(ORDCHK)>255 S @TMP@(TMP("ORDIV"),DSPGRP,ORDCHK1,STRDT,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)_U_ORDCHK2
"RTN","ORSRCHOR",88,0)
 . . . E  S @TMP@(TMP("ORDIV"),DSPGRP,ORDCHK,STRDT,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)
"RTN","ORSRCHOR",89,0)
 . . I (ANS("SORT")="DSPGRP")&($P($G(^ORD(101.41,+$P($G(^OR(100,ORDNO,0)),U,5),0)),U,5)=TMP("ORDGPIEN"))  D
"RTN","ORSRCHOR",90,0)
 . . . I $L(ORDCHK)>255 S @TMP@(TMP("ORDSPGRP"),DIVISN,ORDCHK1,STRDT,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)_U_ORDCHK2
"RTN","ORSRCHOR",91,0)
 . . . E  S @TMP@(TMP("ORDSPGRP"),DIVISN,ORDCHK,STRDT,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)
"RTN","ORSRCHOR",92,0)
 . . I (ANS("SORT")="DTORD")&($P($G(^SC(+$P($G(^OR(100,ORDNO,0)),U,10),0)),U,15)=TMP("ORDIVIEN"))&($P($G(^ORD(101.41,+$P($G(^OR(100,ORDNO,0)),U,5),0)),U,5)=TMP("ORDGPIEN"))  D
"RTN","ORSRCHOR",93,0)
 . . . I $L(ORDCHK)>255 S @TMP@(STRDT,TMP("ORDIV"),TMP("ORDSPGRP"),ORDCHK1,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)_U_ORDCHK2
"RTN","ORSRCHOR",94,0)
 . . . E  S @TMP@(STRDT,TMP("ORDIV"),TMP("ORDSPGRP"),ORDCHK,ORDNO)=ORD8_U_$P(ORD9,U,4)_U_$P(ORD9,U,5)_U_$P(ORD9,U,6)
"RTN","ORSRCHOR",95,0)
 K ^TMP($J,"OROCDATA")
"RTN","ORSRCHOR",96,0)
 Q
"RTN","ORSRCHOR",97,0)
 ;
"RTN","ORSRCHOR",98,0)
HEADER ; Prints out the report header
"RTN","ORSRCHOR",99,0)
 ;
"RTN","ORSRCHOR",100,0)
 N SORT,SRTORD,TITLE,PERTTL,TTLIEN S TITLE="Order Check Override Reason Report",SORT="Sorted in Ascending order by: "
"RTN","ORSRCHOR",101,0)
 I ANS("SORT")="OVRDNBY" S SRTORD="Date/Time Ordered, Division, Display Group, Order Chk, & Order#"
"RTN","ORSRCHOR",102,0)
 I ANS("SORT")="ORCHK" S SRTORD="Order Chk, Division, Display Group, Date/Time Ordered, & Order#"
"RTN","ORSRCHOR",103,0)
 I ANS("SORT")="DTORD" S SRTORD="Date/Time Ordered, Order Chk, & Order#"
"RTN","ORSRCHOR",104,0)
 I ANS("SORT")="DIV" S SRTORD="Display Group, Order Chk, Date/Time Ordered, & Order#"
"RTN","ORSRCHOR",105,0)
 I ANS("SORT")="DSPGRP" S SRTORD="Division, Order Chk, Date/Time Ordered, & Order#"
"RTN","ORSRCHOR",106,0)
 I $D(IO("SPOOL"))!($D(IO("HFSIO"))) S IOM=80
"RTN","ORSRCHOR",107,0)
 W @IOF,?(IOM-$L(TITLE))/2,TITLE,!?(IOM-$L(SORT))/2,SORT,!?(IOM-$L(SRTORD))/2,SRTORD
"RTN","ORSRCHOR",108,0)
 W !!!,"Current User:  ",$E($$GET1^DIQ(200,+$G(DUZ),.01),1,26),?42,"Current Date:  ",$$HTE^XLFDT($H)
"RTN","ORSRCHOR",109,0)
 W !,"Date Range Searched:  ",$$FMTE^XLFDT(TMP("STRDT"),"1D")," - ",$$FMTE^XLFDT(TMP("ENDDT"),"1D"),?54,"WHERE"
"RTN","ORSRCHOR",110,0)
 I ANS("SORT")="OVRDNBY" D
"RTN","ORSRCHOR",111,0)
 . S TTLIEN=$P($G(^VA(200,TMP("OVRBYIEN"),0)),U,9) I TTLIEN="" S PERTTL="NONE SPECIFIED"
"RTN","ORSRCHOR",112,0)
 . E  S PERTTL=$P($G(^DIC(3.1,TTLIEN,0)),U) I PERTTL="" S PERTTL="NONE SPECIFIED"
"RTN","ORSRCHOR",113,0)
 . W !,"Order Chks are Overridden By:  ",TMP("OVRBY"),!,"Title:  ",PERTTL,!!
"RTN","ORSRCHOR",114,0)
 I ANS("SORT")="ORCHK" W !,"Order Check:  ",TMP("ORCHK"),!!
"RTN","ORSRCHOR",115,0)
 I ANS("SORT")="DIV" W !,"Division:  ",TMP("ORDIV"),!!
"RTN","ORSRCHOR",116,0)
 I ANS("SORT")="DSPGRP" W !,"Display Group:  ",TMP("ORDSPGRP"),!!
"RTN","ORSRCHOR",117,0)
 I ANS("SORT")="DTORD" W !,"Division:  ",TMP("ORDIV"),!,"Display Group:  ",TMP("ORDSPGRP"),!!
"RTN","ORSRCHOR",118,0)
 I ANS("DELIMIT")="YES"&($D(^TMP("OROVRRPT",$J))) D
"RTN","ORSRCHOR",119,0)
 . S TMP("DLMTR")=$S(ANS("DELIMITER")="P":"|",ANS("DELIMITER")="T":"~",ANS("DELIMITER")="U":"^")
"RTN","ORSRCHOR",120,0)
 . I ANS("SORT")="OVRDNBY" W "RECNO"_TMP("DLMTR")_"Date/Time Ordered"_TMP("DLMTR")_"Division"_TMP("DLMTR")_"Display Group"_TMP("DLMTR")_"Order#"_TMP("DLMTR")_"D/T Overridden"
"RTN","ORSRCHOR",121,0)
 . I ANS("SORT")="ORCHK" W "RECNO"_TMP("DLMTR")_"Date/Time Ordered"_TMP("DLMTR")_"Division"_TMP("DLMTR")_"Display Group"_TMP("DLMTR")_"Order#"_TMP("DLMTR")_"Overridden by"_TMP("DLMTR")_"D/T Overridden"
"RTN","ORSRCHOR",122,0)
 . I ANS("SORT")="DIV" W "RECNO"_TMP("DLMTR")_"Date/Time Ordered"_TMP("DLMTR")_"Display Group"_TMP("DLMTR")_"Order#"_TMP("DLMTR")_"Overridden by"_TMP("DLMTR")_"D/T Overridden"
"RTN","ORSRCHOR",123,0)
 . I ANS("SORT")="DSPGRP" W "RECNO"_TMP("DLMTR")_"Date/Time Ordered"_TMP("DLMTR")_"Division"_TMP("DLMTR")_"Order#"_TMP("DLMTR")_"Overridden by"_TMP("DLMTR")_"D/T Overridden"
"RTN","ORSRCHOR",124,0)
 . I ANS("SORT")="DTORD" W "RECNO"_TMP("DLMTR")_"Date/Time Ordered"_TMP("DLMTR")_"Order#"_TMP("DLMTR")_"Overridden by"_TMP("DLMTR")_"D/T Overridden"
"RTN","ORSRCHOR",125,0)
COLHDR I ANS("DELIMIT")="NO" D
"RTN","ORSRCHOR",126,0)
 . I ANS("SORT")="OVRDNBY"!(ANS("SORT")="ORCHK") W "Date/Time Ordered",?21,"Division",?40,"Display Group",?70,"Order#",!,"-----------------",?21,"--------",?40,"-------------",?70,"------"
"RTN","ORSRCHOR",127,0)
 . I ANS("SORT")="DIV" W "Date/Time Ordered",?25,"Display Group",?60,"Order#",!,"-----------------",?25,"-------------",?60,"------"
"RTN","ORSRCHOR",128,0)
 . I ANS("SORT")="DSPGRP" W "Date/Time Ordered",?25,"Division",?60,"Order#",!,"-----------------",?25,"--------",?60,"------"
"RTN","ORSRCHOR",129,0)
 . I ANS("SORT")="DTORD" W "Date/Time Ordered",?45,"Order#",!,"-----------------",?45,"------"
"RTN","ORSRCHOR",130,0)
 Q
"RTN","ORSRCHOR",131,0)
 ;
"RTN","ORY293")
0^8^B2220767
"RTN","ORY293",1,0)
ORY293 ;SLC/JMH - post install routine for patch OR*3*293; ;06/07/10  05:16
"RTN","ORY293",2,0)
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**293**;Dec 17, 1997;Build 20
"RTN","ORY293",3,0)
 ;
"RTN","ORY293",4,0)
POST ;
"RTN","ORY293",5,0)
 ;task out CONVERT^OROCAPI1
"RTN","ORY293",6,0)
 D TASK
"RTN","ORY293",7,0)
 Q
"RTN","ORY293",8,0)
 ;
"RTN","ORY293",9,0)
TASK ; -- queue job to convert order checks
"RTN","ORY293",10,0)
 N ZTDESC,ZTRTN,ZTIO,ZTSAVE,ZTDTH,ZTSK,ORMSG
"RTN","ORY293",11,0)
 S ORMSG(1)="A background job has been queued to convert order checks"
"RTN","ORY293",12,0)
 S ORMSG(2)="from file 100 to file 100.05." D MES^XPDUTL(.ORMSG)
"RTN","ORY293",13,0)
 S ZTDESC="Convert Order Checks",ZTRTN="CONVERT^OROCAPI1"
"RTN","ORY293",14,0)
 S ZTIO="",ZTDTH=$H,ZTSAVE("DUZ")="" D ^%ZTLOAD K ORMSG
"RTN","ORY293",15,0)
 S ORMSG="Task "_$S($G(ZTSK):"#"_ZTSK,1:"not")_" started."
"RTN","ORY293",16,0)
 D MES^XPDUTL(ORMSG)
"RTN","ORY293",17,0)
 I '$G(ZTSK) D BMES^XPDUTL("Use TASK^ORY293 to queue this job to complete conversion of order checks!")
"RTN","ORY293",18,0)
 S ^XTMP("ORK FILE CONVERSION",0)=$$FMADD^XLFDT($$NOW^XLFDT,90)_U_$$NOW^XLFDT
"RTN","ORY293",19,0)
 S ^XTMP("ORK FILE CONVERSION","INSTALLER")=DUZ
"RTN","ORY293",20,0)
 Q
"RTN","ORY293",21,0)
 ;
"SEC","^DIC",100.05,100.05,0,"AUDIT")
@
"SEC","^DIC",100.05,100.05,0,"DD")
@
"SEC","^DIC",100.05,100.05,0,"DEL")
@
"SEC","^DIC",100.05,100.05,0,"LAYGO")
@
"SEC","^DIC",100.05,100.05,0,"RD")
@
"SEC","^DIC",100.05,100.05,0,"WR")
@
"VER")
8.0^22.0
"^DD",100.05,100.05,0)
FIELD^^16^20
"^DD",100.05,100.05,0,"DDA")
N
"^DD",100.05,100.05,0,"DT")
3090618
"^DD",100.05,100.05,0,"IX","B",100.05,.01)

"^DD",100.05,100.05,0,"NM","ORDER CHECK INSTANCES")

"^DD",100.05,100.05,0,"VRPK")
OR
"^DD",100.05,100.05,.01,0)
ORDER^RP100'^OR(100,^0;1^Q
"^DD",100.05,100.05,.01,1,0)
^.1
"^DD",100.05,100.05,.01,1,1,0)
100.05^B
"^DD",100.05,100.05,.01,1,1,1)
S ^ORD(100.05,"B",$E(X,1,30),DA)=""
"^DD",100.05,100.05,.01,1,1,2)
K ^ORD(100.05,"B",$E(X,1,30),DA)
"^DD",100.05,100.05,.01,3)
Select the order that this order check is in reference to
"^DD",100.05,100.05,.01,21,0)
^^1^1^3090121^^
"^DD",100.05,100.05,.01,21,1,0)
This gives the order that the Order Check is related to.
"^DD",100.05,100.05,.01,"DT")
3090121
"^DD",100.05,100.05,1,0)
STATUS^P100.01'^ORD(100.01,^0;2^Q
"^DD",100.05,100.05,1,3)
Enter the status of the order when the order check occurred.
"^DD",100.05,100.05,1,21,0)
^^1^1^3090116^^
"^DD",100.05,100.05,1,21,1,0)
This is the status of the order when the Order Check occurred.
"^DD",100.05,100.05,1,"DT")
3090116
"^DD",100.05,100.05,2,0)
OCCURRENCE^F^^0;3^K:$L(X)>15!($L(X)<1) X
"^DD",100.05,100.05,2,3)
Enter a descriptor tag between 1 and 15 characters
"^DD",100.05,100.05,2,21,0)
^^6^6^3090116^
"^DD",100.05,100.05,2,21,1,0)
This is a description field that the application where the order check 
"^DD",100.05,100.05,2,21,2,0)
occurred can use to describe where/when the order check took place.  For 
"^DD",100.05,100.05,2,21,3,0)
instance, CPRS will use ACCEPTANCE_CPRS when the order check happened at 
"^DD",100.05,100.05,2,21,4,0)
order acceptance inside of the CPRS application. CPRS will use 
"^DD",100.05,100.05,2,21,5,0)
SIGNATURE_CPRS when the order check happened at order signature inside of 
"^DD",100.05,100.05,2,21,6,0)
the CPRS application.
"^DD",100.05,100.05,2,"DT")
3090116
"^DD",100.05,100.05,3,0)
USER^P200'^VA(200,^0;4^Q
"^DD",100.05,100.05,3,3)
Enter the user who saw the order checks
"^DD",100.05,100.05,3,21,0)
^^1^1^3090121^
"^DD",100.05,100.05,3,21,1,0)
This is the user that saw the order checks.
"^DD",100.05,100.05,3,"DT")
3090121
"^DD",100.05,100.05,4,0)
OCCURRENCE D/T^D^^0;5^S %DT="E" D ^%DT S X=Y K:X<1 X
"^DD",100.05,100.05,4,3)
Enter the date/time of the order check
"^DD",100.05,100.05,4,21,0)
^^1^1^3090115^
"^DD",100.05,100.05,4,21,1,0)
This is the date/time that the order checks happened.
"^DD",100.05,100.05,4,"DT")
3090121
"^DD",100.05,100.05,5,0)
ORDER CHECK^P100.8'^ORD(100.8,^1;1^Q
"^DD",100.05,100.05,5,3)
Enter the type of Order Check
"^DD",100.05,100.05,5,21,0)
^^1^1^3090121^
"^DD",100.05,100.05,5,21,1,0)
This field represents what type of order check took place
"^DD",100.05,100.05,5,"DT")
3090121
"^DD",100.05,100.05,6,0)
CLINICAL DANGER LEVEL^S^1:HIGH;2:MODERATE;3:LOW;^1;2^Q
"^DD",100.05,100.05,6,3)
Enter the Clinical Danger Level of this Order Check
"^DD",100.05,100.05,6,21,0)
^^2^2^3090115^
"^DD",100.05,100.05,6,21,1,0)
This is the clinical danger of the Order Check type (file 100.8) at the 
"^DD",100.05,100.05,6,21,2,0)
time this order check was seen.
"^DD",100.05,100.05,6,"DT")
3090115
"^DD",100.05,100.05,7,0)
OVERRIDE REASON^100.57^^3;0
"^DD",100.05,100.05,7,21,0)
^^2^2^3090116^
"^DD",100.05,100.05,7,21,1,0)
This field represents the reason that the provider is overriding the 
"^DD",100.05,100.05,7,21,2,0)
order check and continuing with placing the order.
"^DD",100.05,100.05,8,0)
ORDER CHECK MESSAGE^100.58^^2;0
"^DD",100.05,100.05,8,21,0)
^^2^2^3090115^
"^DD",100.05,100.05,8,21,1,0)
This field stores the text of the order check that was presented to the 
"^DD",100.05,100.05,8,21,2,0)
user.
"^DD",100.05,100.05,9,0)
SEVERITY LEVEL^F^^10;1^K:$L(X)>30!($L(X)<1) X
"^DD",100.05,100.05,9,3)
Answer must be 1-30 characters in length
"^DD",100.05,100.05,9,"DT")
3070711
"^DD",100.05,100.05,10,0)
INTERVENTION IEN^P9009032.4'^APSPQA(32.4,^10;2^Q
"^DD",100.05,100.05,10,"DT")
3070711
"^DD",100.05,100.05,11,0)
DOSAGE ORDERED^F^^10;3^K:$L(X)>80!($L(X)<1) X
"^DD",100.05,100.05,11,3)
Answer must be 1-80 characters in length
"^DD",100.05,100.05,11,"DT")
3070711
"^DD",100.05,100.05,12,0)
ORDER CHECK DATABASE^S^V:VISTA;F:FDB;^10;4^Q
"^DD",100.05,100.05,12,"DT")
3070711
"^DD",100.05,100.05,13,0)
PHARMACIST OVERRIDE COMMENTS^F^^11;1^K:$L(X)>80!($L(X)<1) X
"^DD",100.05,100.05,13,3)
Enter the reason that the pharmacist is overriding the order check
"^DD",100.05,100.05,13,21,0)
^^2^2^3090116^
"^DD",100.05,100.05,13,21,1,0)
This field represents the reason that the Pharmacist is overriding the 
"^DD",100.05,100.05,13,21,2,0)
Order Check and continuing with placing the order.
"^DD",100.05,100.05,13,"DT")
3090116
"^DD",100.05,100.05,14,0)
PHARMACIST^P200'^VA(200,^11;2^Q
"^DD",100.05,100.05,14,3)
Enter the Pharmacist who is entering the Pharmacist Override Comments
"^DD",100.05,100.05,14,8.5)
@
"^DD",100.05,100.05,14,21,0)
^^1^1^3090121^
"^DD",100.05,100.05,14,21,1,0)
This is the Pharmacist who entered the Pharmacist Override Comments
"^DD",100.05,100.05,14,"DT")
3090121
"^DD",100.05,100.05,14.1,0)
PHARMACIST COMMENTS D/T^D^^15;1^S %DT="EST" D ^%DT S X=Y K:Y<1 X
"^DD",100.05,100.05,14.1,3)
Enter the date/time that the Pharmacist Override Comments were entered.
"^DD",100.05,100.05,14.1,21,0)
^^2^2^3090116^
"^DD",100.05,100.05,14.1,21,1,0)
This field represents the Date and Time that the Pharmacist Override 
"^DD",100.05,100.05,14.1,21,2,0)
Comments were entered.
"^DD",100.05,100.05,14.1,"DT")
3090121
"^DD",100.05,100.05,15,0)
MONOGRAPH^100.515^^16;0
"^DD",100.05,100.05,15,21,0)
^^1^1^3091023^
"^DD",100.05,100.05,15,21,1,0)
This field stores the monograph for Drug-Drug Interactions.
"^DD",100.05,100.05,16,0)
MONOGRAPH TERM^F^^17;1^K:$L(X)>50!($L(X)<1) X
"^DD",100.05,100.05,16,3)
Answer must be 1-50 characters in length
"^DD",100.05,100.05,16,21,0)
^^2^2^3090618^
"^DD",100.05,100.05,16,21,1,0)
This is the term that will be displayed to the user when selecting from a 
"^DD",100.05,100.05,16,21,2,0)
list of monographs to view.
"^DD",100.05,100.05,16,"DT")
3090618
"^DD",100.05,100.05,17,0)
DISPENSE FREQUENCY^S^W:WEEKLY;B:BI-WEEKLY;M:MONTHLY;^13;2^Q
"^DD",100.05,100.05,17,"DT")
3070816
"^DD",100.05,100.05,18,0)
LAB RESULTS^100.518D^^14;0
"^DD",100.05,100.515,0)
MONOGRAPH SUB-FIELD^^.01^4
"^DD",100.05,100.515,0,"DT")
3090617
"^DD",100.05,100.515,0,"IX","B",100.515,.01)

"^DD",100.05,100.515,0,"NM","MONOGRAPH")

"^DD",100.05,100.515,0,"UP")
100.05
"^DD",100.05,100.515,.01,0)
MONOGRAPH^WKx^^0;1^K:$L(X)>245 X D:$D(X) ^DIM
"^DD",100.05,100.515,.01,.1)
MONOGRAPH DATA
"^DD",100.05,100.515,.01,1,0)
^.1
"^DD",100.05,100.515,.01,1,1,0)
100.515^B
"^DD",100.05,100.515,.01,1,1,1)
S ^ORD(100.05,DA(1),12,"B",$E(X,1,30),DA)=""
"^DD",100.05,100.515,.01,1,1,2)
K ^ORD(100.05,DA(1),12,"B",$E(X,1,30),DA)
"^DD",100.05,100.515,.01,3)
Enter Standard MUMPS code
"^DD",100.05,100.515,.01,9)
@
"^DD",100.05,100.515,.01,21,0)
^^2^2^3090617^
"^DD",100.05,100.515,.01,21,1,0)
This field will hold the monograph data that pharmacy sends back with 
"^DD",100.05,100.515,.01,21,2,0)
Drug Interaction order checks.
"^DD",100.05,100.515,.01,23,0)
^^1^1^3090617^
"^DD",100.05,100.515,.01,23,1,0)
This will be a word processing field with word wrap on.
"^DD",100.05,100.515,.01,"DT")
3090617
"^DD",100.05,100.515,1,0)
LOCATION^S^R:REMOTE;L:LOCAL;B:BOTH;^0;2^Q
"^DD",100.05,100.515,1,"DT")
3070711
"^DD",100.05,100.515,2,0)
SIGN/SYMPTOMS^100.5152P^^1;0
"^DD",100.05,100.515,3,0)
INTERACTING MED ORDER^100.5153^^2;0
"^DD",100.05,100.5152,0)
SIGN/SYMPTOMS SUB-FIELD^^.01^1
"^DD",100.05,100.5152,0,"DT")
3070711
"^DD",100.05,100.5152,0,"IX","B",100.5152,.01)

"^DD",100.05,100.5152,0,"NM","SIGN/SYMPTOMS")

"^DD",100.05,100.5152,0,"UP")
100.515
"^DD",100.05,100.5152,.01,0)
SIGN/SYMPTOMS^P120.83'^GMRD(120.83,^0;1^Q
"^DD",100.05,100.5152,.01,1,0)
^.1
"^DD",100.05,100.5152,.01,1,1,0)
100.5152^B
"^DD",100.05,100.5152,.01,1,1,1)
S ^ORD(100.05,DA(2),12,DA(1),1,"B",$E(X,1,30),DA)=""
"^DD",100.05,100.5152,.01,1,1,2)
K ^ORD(100.05,DA(2),12,DA(1),1,"B",$E(X,1,30),DA)
"^DD",100.05,100.5152,.01,"DT")
3070711
"^DD",100.05,100.5153,0)
INTERACTING MED ORDER SUB-FIELD^^4^4
"^DD",100.05,100.5153,0,"DT")
3070717
"^DD",100.05,100.5153,0,"IX","B",100.5153,.01)

"^DD",100.05,100.5153,0,"NM","INTERACTING MED ORDER")

"^DD",100.05,100.5153,0,"UP")
100.515
"^DD",100.05,100.5153,.01,0)
INTERACTING MED ORDER^F^^0;1^K:$L(X)>30!($L(X)<1) X
"^DD",100.05,100.5153,.01,1,0)
^.1
"^DD",100.05,100.5153,.01,1,1,0)
100.5153^B
"^DD",100.05,100.5153,.01,1,1,1)
S ^ORD(100.05,DA(2),12,DA(1),2,"B",$E(X,1,30),DA)=""
"^DD",100.05,100.5153,.01,1,1,2)
K ^ORD(100.05,DA(2),12,DA(1),2,"B",$E(X,1,30),DA)
"^DD",100.05,100.5153,.01,3)
Answer must be 1-30 characters in length
"^DD",100.05,100.5153,.01,"DT")
3070717
"^DD",100.05,100.5153,2,0)
STATUS^F^^0;3^K:$L(X)>30!($L(X)<1) X
"^DD",100.05,100.5153,2,3)
Answer must be 1-30 characters in length
"^DD",100.05,100.5153,2,"DT")
3070711
"^DD",100.05,100.5153,3,0)
REMOTE LOCATION^F^^0;4^K:$L(X)>40!($L(X)<1) X
"^DD",100.05,100.5153,3,3)
Answer must be 1-40 characters in length
"^DD",100.05,100.5153,3,"DT")
3070711
"^DD",100.05,100.5153,4,0)
INTERACTING DRUGS^100.51534^^1;0
"^DD",100.05,100.51534,0)
INTERACTING DRUGS SUB-FIELD^^3^4
"^DD",100.05,100.51534,0,"DT")
3070711
"^DD",100.05,100.51534,0,"IX","B",100.51534,.01)

"^DD",100.05,100.51534,0,"NM","INTERACTING DRUGS")

"^DD",100.05,100.51534,0,"UP")
100.5153
"^DD",100.05,100.51534,.01,0)
DRUG NAME^F^^0;1^K:$L(X)>64!($L(X)<1) X
"^DD",100.05,100.51534,.01,1,0)
^.1
"^DD",100.05,100.51534,.01,1,1,0)
100.51534^B
"^DD",100.05,100.51534,.01,1,1,1)
S ^ORD(100.05,DA(3),12,DA(2),2,DA(1),1,"B",$E(X,1,30),DA)=""
"^DD",100.05,100.51534,.01,1,1,2)
K ^ORD(100.05,DA(3),12,DA(2),2,DA(1),1,"B",$E(X,1,30),DA)
"^DD",100.05,100.51534,.01,3)
Answer must be 1-64 characters in length
"^DD",100.05,100.51534,.01,"DT")
3070711
"^DD",100.05,100.51534,1,0)
INTERACTING DRUG^P50'^PSDRUG(^0;2^Q
"^DD",100.05,100.51534,1,"DT")
3070711
"^DD",100.05,100.51534,2,0)
VA PRODUCT VUID^F^^0;3^K:$L(X)>20!($L(X)<1) X
"^DD",100.05,100.51534,2,3)
Answer must be 1-20 characters in length
"^DD",100.05,100.51534,2,"DT")
3070711
"^DD",100.05,100.51534,3,0)
GCNSEQNO^NJ9,0^^0;4^K:+X'=X!(X>999999999)!(X<0)!(X?.E1"."1.N) X
"^DD",100.05,100.51534,3,3)
Type a number between 0 and 999999999, 0 Decimal Digits
"^DD",100.05,100.51534,3,"DT")
3070711
"^DD",100.05,100.518,0)
LAB RESULTS SUB-FIELD^^4^5
"^DD",100.05,100.518,0,"DT")
3070816
"^DD",100.05,100.518,0,"IX","B",100.518,.01)

"^DD",100.05,100.518,0,"NM","LAB RESULTS")

"^DD",100.05,100.518,0,"UP")
100.05
"^DD",100.05,100.518,.01,0)
RESULTS DATE/TIME^D^^0;1^S %DT="E" D ^%DT S X=Y K:X<1 X
"^DD",100.05,100.518,.01,1,0)
^.1
"^DD",100.05,100.518,.01,1,1,0)
100.518^B
"^DD",100.05,100.518,.01,1,1,1)
S ^ORD(100.05,DA(1),14,"B",$E(X,1,30),DA)=""
"^DD",100.05,100.518,.01,1,1,2)
K ^ORD(100.05,DA(1),14,"B",$E(X,1,30),DA)
"^DD",100.05,100.518,.01,3)
(No range limit on date)
"^DD",100.05,100.518,.01,"DT")
3070816
"^DD",100.05,100.518,1,0)
WBC TEST NAME^F^^0;2^K:$L(X)>40!($L(X)<3) X
"^DD",100.05,100.518,1,3)
Answer must be 3-40 characters in length
"^DD",100.05,100.518,1,"DT")
3070816
"^DD",100.05,100.518,2,0)
WBC RESULT^NJ9,3X^^0;3^K:+X'=X!(X>99999)!(X<0)!(X?.E1"."4.N) X
"^DD",100.05,100.518,2,3)
Type a Number between 0 and 99999, 3 Decimal Digits
"^DD",100.05,100.518,2,"DT")
3070816
"^DD",100.05,100.518,3,0)
ANC TEST NAME^F^^0;4^K:$L(X)>40!($L(X)<3) X
"^DD",100.05,100.518,3,3)
Answer must be 3-40 characters in length
"^DD",100.05,100.518,3,"DT")
3070816
"^DD",100.05,100.518,4,0)
ANC RESULT^NJ9,3^^0;5^K:+X'=X!(X>99999)!(X<0)!(X?.E1"."4.N) X
"^DD",100.05,100.518,4,3)
Type a number between 0 and 99999, 3 Decimal Digits
"^DD",100.05,100.518,4,"DT")
3070816
"^DD",100.05,100.57,0)
OVERRIDE REASON SUB-FIELD^^.01^1
"^DD",100.05,100.57,0,"DT")
3070622
"^DD",100.05,100.57,0,"NM","OVERRIDE REASON")

"^DD",100.05,100.57,0,"UP")
100.05
"^DD",100.05,100.57,.01,0)
OVERRIDE REASON^W^^0;1
"^DD",100.05,100.57,.01,"DT")
3070622
"^DD",100.05,100.58,0)
ORDER CHECK MESSAGE SUB-FIELD^^.01^1
"^DD",100.05,100.58,0,"DT")
3070622
"^DD",100.05,100.58,0,"NM","ORDER CHECK MESSAGE")

"^DD",100.05,100.58,0,"UP")
100.05
"^DD",100.05,100.58,.01,0)
ORDER CHECK MESSAGE^W^^0;1
"^DD",100.05,100.58,.01,"DT")
3070622
"^DIC",100.05,100.05,0)
ORDER CHECK INSTANCES^100.05
"^DIC",100.05,100.05,0,"GL")
^ORD(100.05,
"^DIC",100.05,100.05,"%",0)
^1.005^^0
"^DIC",100.05,100.05,"%D",0)
^^2^2^3090121^
"^DIC",100.05,100.05,"%D",1,0)
The purpose of this file is to create a repository for instances of order 
"^DIC",100.05,100.05,"%D",2,0)
checks that are presented to the users of VISTA across all applications.  
"^DIC",100.05,"B","ORDER CHECK INSTANCES",100.05)

**INSTALL NAME**
GMRA*4.0*45
"BLD",19522,0)
GMRA*4.0*45^ADVERSE REACTION TRACKING^0^3110210^y
"BLD",19522,4,0)
^9.64PA^^
"BLD",19522,6)
2^
"BLD",19522,6.3)
5
"BLD",19522,"KRN",0)
^9.67PA^779.2^20
"BLD",19522,"KRN",.4,0)
.4
"BLD",19522,"KRN",.401,0)
.401
"BLD",19522,"KRN",.402,0)
.402
"BLD",19522,"KRN",.403,0)
.403
"BLD",19522,"KRN",.5,0)
.5
"BLD",19522,"KRN",.84,0)
.84
"BLD",19522,"KRN",3.6,0)
3.6
"BLD",19522,"KRN",3.8,0)
3.8
"BLD",19522,"KRN",9.2,0)
9.2
"BLD",19522,"KRN",9.8,0)
9.8
"BLD",19522,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",19522,"KRN",9.8,"NM",1,0)
GMRAUTL2^^0^B88611028
"BLD",19522,"KRN",9.8,"NM",2,0)
GMRAFX3^^0^B69479598
"BLD",19522,"KRN",9.8,"NM","B","GMRAFX3",2)

"BLD",19522,"KRN",9.8,"NM","B","GMRAUTL2",1)

"BLD",19522,"KRN",19,0)
19
"BLD",19522,"KRN",19.1,0)
19.1
"BLD",19522,"KRN",101,0)
101
"BLD",19522,"KRN",409.61,0)
409.61
"BLD",19522,"KRN",771,0)
771
"BLD",19522,"KRN",779.2,0)
779.2
"BLD",19522,"KRN",870,0)
870
"BLD",19522,"KRN",8989.51,0)
8989.51
"BLD",19522,"KRN",8989.52,0)
8989.52
"BLD",19522,"KRN",8994,0)
8994
"BLD",19522,"KRN","B",.4,.4)

"BLD",19522,"KRN","B",.401,.401)

"BLD",19522,"KRN","B",.402,.402)

"BLD",19522,"KRN","B",.403,.403)

"BLD",19522,"KRN","B",.5,.5)

"BLD",19522,"KRN","B",.84,.84)

"BLD",19522,"KRN","B",3.6,3.6)

"BLD",19522,"KRN","B",3.8,3.8)

"BLD",19522,"KRN","B",9.2,9.2)

"BLD",19522,"KRN","B",9.8,9.8)

"BLD",19522,"KRN","B",19,19)

"BLD",19522,"KRN","B",19.1,19.1)

"BLD",19522,"KRN","B",101,101)

"BLD",19522,"KRN","B",409.61,409.61)

"BLD",19522,"KRN","B",771,771)

"BLD",19522,"KRN","B",779.2,779.2)

"BLD",19522,"KRN","B",870,870)

"BLD",19522,"KRN","B",8989.51,8989.51)

"BLD",19522,"KRN","B",8989.52,8989.52)

"BLD",19522,"KRN","B",8994,8994)

"BLD",19522,"QUES",0)
^9.62^^
"BLD",19522,"REQB",0)
^9.611^2^2
"BLD",19522,"REQB",1,0)
GMRA*4.0*20^2
"BLD",19522,"REQB",2,0)
GMRA*4.0*41^2
"BLD",19522,"REQB","B","GMRA*4.0*20",1)

"BLD",19522,"REQB","B","GMRA*4.0*41",2)

"MBREQ")
1
"PKG",91,-1)
1^1
"PKG",91,0)
ADVERSE REACTION TRACKING^GMRA^Allergy Tracking System
"PKG",91,20,0)
^9.402P^^
"PKG",91,22,0)
^9.49I^1^1
"PKG",91,22,1,0)
4.0^2960328^2960422^24
"PKG",91,22,1,"PAH",1,0)
45^3110210^1392
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
2
"RTN","GMRAFX3")
0^2^B69479598
"RTN","GMRAFX3",1,0)
GMRAFX3 ;SLC/DAN Update existing entries to new reactant ;03/16/10  08:35
"RTN","GMRAFX3",2,0)
 ;;4.0;Adverse Reaction Tracking;**17,19,23,20,45**;Mar 29, 1996;Build 5
"RTN","GMRAFX3",3,0)
 ;DBIA SECTION
"RTN","GMRAFX3",4,0)
 ;10018 - DIE
"RTN","GMRAFX3",5,0)
 ;2056  - DIQ
"RTN","GMRAFX3",6,0)
 ;3154  - ORQ1
"RTN","GMRAFX3",7,0)
 ;4134  - ORCHECK
"RTN","GMRAFX3",8,0)
 ;4135  - ORKCHK
"RTN","GMRAFX3",9,0)
 ;10026 - DIR
"RTN","GMRAFX3",10,0)
 ;
"RTN","GMRAFX3",11,0)
UIE ;Update individual entries
"RTN","GMRAFX3",12,0)
 N DFN,GMRAOUT,GMRAING,GMRADRCL,DIE,DA,DR,AIFN,SIGN,TIME,SUB,ORX,GMRAORX,GMRAOC,GI,FND,COM,SIEN,DIR,Y
"RTN","GMRAFX3",13,0)
 S GMRADONE=0 ;Flag to keep track of updated entries
"RTN","GMRAFX3",14,0)
 S DFN=$P($G(^GMR(120.8,GMRAPA,0)),U) Q:'+DFN
"RTN","GMRAFX3",15,0)
 W !!,"For patient ",$$GET1^DIQ(2,DFN_",",.01),!
"RTN","GMRAFX3",16,0)
 I $D(GMRAAR) D
"RTN","GMRAFX3",17,0)
 .S DIR(0)="Y",DIR("A")="Use reactant "_GMRAAR(0),DIR("B")="Y" D ^DIR
"RTN","GMRAFX3",18,0)
 .K:'Y GMRAAR
"RTN","GMRAFX3",19,0)
 .Q
"RTN","GMRAFX3",20,0)
 I '$D(GMRAAR) D ^GMRAFX2 I $D(GMRAAR) D RUSURE(.GMRASURE) ;20 Get new reactant
"RTN","GMRAFX3",21,0)
 I '$D(GMRAAR)!('$G(GMRASURE)) K GMRAAR Q  ;20 stop if no reactant selected or if user doesn't want to use selected reactant
"RTN","GMRAFX3",22,0)
 S GMRAOUT=0
"RTN","GMRAFX3",23,0)
 I $$DUP W !,"Patient already has an active allergy for this reactant.",!,"Duplicate not allowed.",! D WAIT Q
"RTN","GMRAFX3",24,0)
 I $$DUPCHK^GMRAPES0(GMRAAR(0),DFN,GMRAPA) Q  ;Checks to see if reactant previously entered in error.
"RTN","GMRAFX3",25,0)
 ;Update reactant, allergy and signed off fields
"RTN","GMRAFX3",26,0)
 S DIE="^GMR(120.8,",DA=GMRAPA,DR=".02////"_GMRAAR(0)_";1////^S X=GMRAAR"_";3.1////"_GMRAAR("O")_";15///1" D ^DIE
"RTN","GMRAFX3",27,0)
 I $D(^GMR(120.85,"C",GMRAPA)) D  ;Observed reaction, need to update data
"RTN","GMRAFX3",28,0)
 .S AIFN=0
"RTN","GMRAFX3",29,0)
 .F  S AIFN=$O(^GMR(120.85,"C",GMRAPA,AIFN)) Q:'+AIFN  D
"RTN","GMRAFX3",30,0)
 ..S SIEN=$O(^GMR(120.85,AIFN,3,"B",$P(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR),"^"),0)) Q:'+SIEN  ;Was previous reactant stored as "suspected agent"
"RTN","GMRAFX3",31,0)
 ..S DA(1)=AIFN,DA=SIEN
"RTN","GMRAFX3",32,0)
 ..S DIE="^GMR(120.85,DA(1),3,",DR=".01////^S X=GMRAAR(0)" D ^DIE ;Update suspected agent to new value
"RTN","GMRAFX3",33,0)
 D DELMUL(2),DELMUL(3) ;Delete drug ingredient/drug classes multiples
"RTN","GMRAFX3",34,0)
 I GMRAAR("O")["D" D UPDATE^GMRAPES1 ;If reactant type is Drug then add appropriate ingredients and classes
"RTN","GMRAFX3",35,0)
 S GMRADONE=1 ;Update complete
"RTN","GMRAFX3",36,0)
 S COM="Updated using clean up process.  Changed reactant from "_$P(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR),"^",2)_$S(LTYPE="FREE":" (free text) ",LTYPE="ING":" (ingredient) ",1:" (drug class) ")_"to "_GMRAAR(0)_"(file - "_$P(GMRAAR,";",2)_")"
"RTN","GMRAFX3",37,0)
 D ADCOM^GMRAFX(GMRAPA,"O",COM) ;Add a comment for this update
"RTN","GMRAFX3",38,0)
 ;Do order checking here - compare existing orders against new allergy information.
"RTN","GMRAFX3",39,0)
 W !,"Performing order checking..."
"RTN","GMRAFX3",40,0)
 K ^TMP("ORR",$J),GMRAOC,ORX
"RTN","GMRAFX3",41,0)
 D EN^ORQ1(DFN_";DPT(") ;Retrieve active orders
"RTN","GMRAFX3",42,0)
 S TIME=$O(^TMP("ORR",$J,0))
"RTN","GMRAFX3",43,0)
 I '^TMP("ORR",$J,TIME,"TOT") W "patient has no active orders." Q  ;20 No orders found
"RTN","GMRAFX3",44,0)
 S SUB=0 F  S SUB=$O(^TMP("ORR",$J,TIME,SUB)) Q:'+SUB  D
"RTN","GMRAFX3",45,0)
 .D BLD^ORCHECK(+^TMP("ORR",$J,TIME,SUB)) ;Get "order" information in order checking format
"RTN","GMRAFX3",46,0)
 M GMRAORX=ORX K ORX ;19
"RTN","GMRAFX3",47,0)
 D EN^ORKCHK(.GMRAOC,DFN,.GMRAORX,"ACCEPT")
"RTN","GMRAFX3",48,0)
 S GI=0,FND=0 F  S GI=$O(GMRAOC(GI)) Q:'+GI  D
"RTN","GMRAFX3",49,0)
 .Q:$P(GMRAOC(GI),U,2)'=3  ;Quit if not allergy related
"RTN","GMRAFX3",50,0)
 .;Q:$D(^OR(100,$P(GMRAOC(GI),U),9,"B",3))  ;23 If order check exists can't be for this data
"RTN","GMRAFX3",51,0)
 .Q:$$ANYARTOC^GMRAUTL2($P(GMRAOC(GI),U))  ;23 If order check exists can't be for this data
"RTN","GMRAFX3",52,0)
 .W !,"Patient has a(n) ",$P($$STATUS^ORQOR2($P(GMRAOC(GI),U)),U,2)," order for",$P($P(GMRAOC(GI),U,4),":",2),", order #",$P(GMRAOC(GI),U)
"RTN","GMRAFX3",53,0)
 .S FND=1
"RTN","GMRAFX3",54,0)
 W:'FND "No problems found"
"RTN","GMRAFX3",55,0)
 D WAIT
"RTN","GMRAFX3",56,0)
 Q
"RTN","GMRAFX3",57,0)
 ;
"RTN","GMRAFX3",58,0)
DELMUL(FIELD) ;Delete multiple FIELD from GMR ALLERGY file
"RTN","GMRAFX3",59,0)
 N MIEN,DA,DIE,DR
"RTN","GMRAFX3",60,0)
 S MIEN=0 F  S MIEN=$O(^GMR(120.8,GMRAPA,FIELD,MIEN)) Q:'+MIEN  D
"RTN","GMRAFX3",61,0)
 .S DA(1)=GMRAPA,DA=MIEN
"RTN","GMRAFX3",62,0)
 .S DIE="^GMR(120.8,DA(1),FIELD,",DR=".01///@" D ^DIE ;Delete entry
"RTN","GMRAFX3",63,0)
 Q
"RTN","GMRAFX3",64,0)
 ;
"RTN","GMRAFX3",65,0)
DUP() ;Function returns true (1) if selected reactant is a duplicate
"RTN","GMRAFX3",66,0)
 N LOOP,FND
"RTN","GMRAFX3",67,0)
 S LOOP=0,FND=0
"RTN","GMRAFX3",68,0)
 F  S LOOP=$O(^GMR(120.8,"B",DFN,LOOP)) Q:'+LOOP!(FND)  D
"RTN","GMRAFX3",69,0)
 .I $P(^GMR(120.8,LOOP,0),U,3)=GMRAAR&('$D(^GMR(120.8,LOOP,"ER"))) S FND=1
"RTN","GMRAFX3",70,0)
 Q FND
"RTN","GMRAFX3",71,0)
 ;
"RTN","GMRAFX3",72,0)
WAIT ;Issues press enter to return prompt
"RTN","GMRAFX3",73,0)
 N DIR
"RTN","GMRAFX3",74,0)
 S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR
"RTN","GMRAFX3",75,0)
 Q
"RTN","GMRAFX3",76,0)
 ;
"RTN","GMRAFX3",77,0)
GETNUM(ACTION) ; -- Return numbers to act on, if action chosen first
"RTN","GMRAFX3",78,0)
 N X,Y,DIR,MAX
"RTN","GMRAFX3",79,0)
 S MAX=$S($D(^TMP($J,LTYPE,"IDX2")):$G(^TMP($J,LTYPE,"IDX2",0)),1:$G(VALMCNT)) Q:MAX'>0 ""
"RTN","GMRAFX3",80,0)
 I ACTION="DET" W !!,"Please choose only one entry for the detailed display."
"RTN","GMRAFX3",81,0)
 S DIR(0)="LAO^1:"_MAX,DIR("A")="Select Entries from list: "
"RTN","GMRAFX3",82,0)
 S DIR("?")="Enter the items you wish to act on, as a range or list of numbers."
"RTN","GMRAFX3",83,0)
 D ^DIR S:$D(DTOUT) Y="^"
"RTN","GMRAFX3",84,0)
 I $D(Y(1)) W !,">>>Too many entries selected, try using smaller ranges" H 2 S Y="^"
"RTN","GMRAFX3",85,0)
 I $L($G(Y),",")>2,ACTION="DET" W !,">>You may only choose ONE group for detailed display." H 2 S Y="^"
"RTN","GMRAFX3",86,0)
 Q Y
"RTN","GMRAFX3",87,0)
 ;
"RTN","GMRAFX3",88,0)
UPDATE ;Update display to account for changes to the list
"RTN","GMRAFX3",89,0)
 N CNT,SP1,SP2,SP3
"RTN","GMRAFX3",90,0)
 I VALMAR["GMRADET" N VALMAR S VALMAR="^XTMP(""GMRAFX"",LTYPE)"
"RTN","GMRAFX3",91,0)
 S CNT=^XTMP("GMRAFX",LTYPE,"GMRAR",$P(ENTRY,U),$P(ENTRY,U,2))-1
"RTN","GMRAFX3",92,0)
 S ^XTMP("GMRAFX",LTYPE,"GMRAR",$P(ENTRY,U),$P(ENTRY,U,2))=CNT K ^($P(ENTRY,U,2),GMRAJ)
"RTN","GMRAFX3",93,0)
 S SP1=4-$L(+NUM),SP2=40-$L($P(ENTRY,U)),SP3=$S(CNT:16-$L(CNT)\2,1:2)
"RTN","GMRAFX3",94,0)
 D SET^VALM10(+NUM,+NUM_$$REPEAT^XLFSTR(" ",SP1)_$P(ENTRY,U,2)_$$REPEAT^XLFSTR(" ",(SP2+SP3))_$S(CNT:CNT,1:"** FIXED **"))
"RTN","GMRAFX3",95,0)
 Q
"RTN","GMRAFX3",96,0)
 ;
"RTN","GMRAFX3",97,0)
LOCK(ENTRY) ;Lock entry in 120.8
"RTN","GMRAFX3",98,0)
 N LOCK
"RTN","GMRAFX3",99,0)
 S LOCK=1
"RTN","GMRAFX3",100,0)
 L +^XTMP("GMRAFX",LTYPE,"IDX",ENTRY):1
"RTN","GMRAFX3",101,0)
 I '$T D FULL^VALM1 S VALMBCK="R" W !,"The ",$P(^XTMP("GMRAFX",LTYPE,"IDX",ENTRY),U)," group is being edited by another user" D WAIT S LOCK=0
"RTN","GMRAFX3",102,0)
 Q LOCK
"RTN","GMRAFX3",103,0)
 ;
"RTN","GMRAFX3",104,0)
AR ;Add/edit patient reactions
"RTN","GMRAFX3",105,0)
 N LCV,DFN,SUB
"RTN","GMRAFX3",106,0)
 S VALMBCK="R" D FULL^VALM1
"RTN","GMRAFX3",107,0)
 W !!,"You should use this option to add NEW reactions only.  If you mark"
"RTN","GMRAFX3",108,0)
 W !,"existing entries as entered in error from within this option it will"
"RTN","GMRAFX3",109,0)
 W !,"not update the utility's display until the list is rebuilt upon re-entry"
"RTN","GMRAFX3",110,0)
 W !,"of this option.  This could cause confusion as the list will no longer"
"RTN","GMRAFX3",111,0)
 W !,"be accurate.",!
"RTN","GMRAFX3",112,0)
 I '$G(NMBR2) D WAIT,EN1^GMRAPEM0 Q
"RTN","GMRAFX3",113,0)
 F LCV=1:1:$L(NMBR2,",")-1 S SUB=$P(NMBR2,",",LCV) S DFN=+$P($G(^GMR(120.8,+$P($G(^TMP($J,LTYPE,"IDX2",SUB)),U,2),0)),U) I DFN W !!,"Now working with patient ",$$GET1^DIQ(2,DFN,.01),! D WAIT D EN2^GMRAPEM0
"RTN","GMRAFX3",114,0)
 Q
"RTN","GMRAFX3",115,0)
 ;
"RTN","GMRAFX3",116,0)
DSPREACT ;Display detailed information about the reactant
"RTN","GMRAFX3",117,0)
 N DIC,DA,GMRAI,STOP,NUM2,DIR,Y
"RTN","GMRAFX3",118,0)
 S VALMBCK="R" D FULL^VALM1
"RTN","GMRAFX3",119,0)
 I '$G(NMBR2) S NMBR2=$$GETNUM("") Q:'+NMBR2
"RTN","GMRAFX3",120,0)
 F GMRAI=1:1:($L(NMBR2,",")-1) D  Q:$G(STOP)
"RTN","GMRAFX3",121,0)
 .S NUM2=$P(NMBR2,",",GMRAI)
"RTN","GMRAFX3",122,0)
 .S DA=$P(^TMP($J,LTYPE,"IDX2",NUM2),U,2) Q:'DA
"RTN","GMRAFX3",123,0)
 .S DIC="^GMR(120.8,"
"RTN","GMRAFX3",124,0)
 .W ! D EN^DIQ
"RTN","GMRAFX3",125,0)
 .S DIR(0)="E",DIR("A")="Press return to continue or '^' to stop" D ^DIR
"RTN","GMRAFX3",126,0)
 .S:$D(DIRUT) STOP=1
"RTN","GMRAFX3",127,0)
 .Q
"RTN","GMRAFX3",128,0)
 Q
"RTN","GMRAFX3",129,0)
 ;
"RTN","GMRAFX3",130,0)
GETTYPE(LTYPE) ;Function determines which list to work with
"RTN","GMRAFX3",131,0)
 N DIR,X,Y
"RTN","GMRAFX3",132,0)
 S DIR(0)="SO^1:Free Text;2:Ingredient;3:Drug Class"
"RTN","GMRAFX3",133,0)
 S DIR("A")="Select the list you wish to work with"
"RTN","GMRAFX3",134,0)
 D ^DIR K DIR
"RTN","GMRAFX3",135,0)
 S LTYPE=$S(Y=1:"FREE",Y=2:"ING",Y=3:"DRUG",1:0)
"RTN","GMRAFX3",136,0)
 Q LTYPE
"RTN","GMRAFX3",137,0)
 ;
"RTN","GMRAFX3",138,0)
EIE ;Mark individual entry as entered in error
"RTN","GMRAFX3",139,0)
 N DIE,DA,DR,Y,DIK,DFN,OROLD,VAIN,X,GMRAOUT
"RTN","GMRAFX3",140,0)
 S DIE="^GMR(120.8,",DA=GMRAPA,DR="15///1;22///1;23///NOW;24////"_$G(DUZ,.5) ;20
"RTN","GMRAFX3",141,0)
 D ^DIE ;Entered in error on date/time by user
"RTN","GMRAFX3",142,0)
 D ADCOM^GMRAFX(GMRAPA,"E","Marked Entered in Error during clean up process")
"RTN","GMRAFX3",143,0)
 I $$NKASCR^GMRANKA($P(^GMR(120.8,GMRAPA,0),U)) D
"RTN","GMRAFX3",144,0)
 .S DIK="^GMR(120.86,",DA=$P(^GMR(120.8,GMRAPA,0),U)
"RTN","GMRAFX3",145,0)
 .D ^DIK ;If patient's last allergy marked as entered in error then delete assessment
"RTN","GMRAFX3",146,0)
 .W !!,"**NOTE: By marking this reaction as entered in error, ",$$GET1^DIQ(2,DA,.01,"E"),!,"no longer has an assessment on file.  You may reassess this patient",!
"RTN","GMRAFX3",147,0)
 .W "now by answering the following prompt or hit return to do it later.",!
"RTN","GMRAFX3",148,0)
 .D NKAASK^GMRANKA(DA)
"RTN","GMRAFX3",149,0)
 S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
"RTN","GMRAFX3",150,0)
 S GMRAOUT=0
"RTN","GMRAFX3",151,0)
 D EN1^GMRAEAB ;Sends entered in error bulletin to appropriate mail groups
"RTN","GMRAFX3",152,0)
 S DFN=$P(GMRAPA(0),U)
"RTN","GMRAFX3",153,0)
 D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA ENTERED IN ERROR")_";ORD(101," ;19
"RTN","GMRAFX3",154,0)
 D:X EN^XQOR ;Process protocols hanging off of "entered in error" protocol
"RTN","GMRAFX3",155,0)
 Q
"RTN","GMRAFX3",156,0)
 ;
"RTN","GMRAFX3",157,0)
RUSURE(GMRASURE) ;20 Make sure selection from ingredient or drug class file is ok
"RTN","GMRAFX3",158,0)
 ;entire section added in patch 20
"RTN","GMRAFX3",159,0)
 N DIR,Y,X
"RTN","GMRAFX3",160,0)
 S GMRASURE=1
"RTN","GMRAFX3",161,0)
 I $G(GMRAAR)["50.416"!($G(GMRAAR)["50.605") D
"RTN","GMRAFX3",162,0)
 .S DIR("A")="Are you sure you want to use this reactant"
"RTN","GMRAFX3",163,0)
 .S DIR("A",1)="You are about to update the entry with a selection from"
"RTN","GMRAFX3",164,0)
 .S DIR("A",2)="the "_$S($G(GMRAAR)["50.416":"INGREDIENT",1:"VA DRUG CLASS")_" file.  By doing that you are"
"RTN","GMRAFX3",165,0)
 .S DIR("A",3)="limiting the information available for order checking."
"RTN","GMRAFX3",166,0)
 .S DIR("A",4)=""
"RTN","GMRAFX3",167,0)
 .S DIR("A",5)="In general, it is better to choose from one of the drug related files"
"RTN","GMRAFX3",168,0)
 .S DIR("A",6)="as that ensures that drug class and ingredient information are part"
"RTN","GMRAFX3",169,0)
 .S DIR("A",7)="of the patient's allergy definition and will provide better allergy"
"RTN","GMRAFX3",170,0)
 .S DIR("A",8)="order checking."
"RTN","GMRAFX3",171,0)
 .S DIR("A",9)=""
"RTN","GMRAFX3",172,0)
 .S DIR(0)="Y",DIR("B")="NO"
"RTN","GMRAFX3",173,0)
 .D ^DIR S GMRASURE=+Y
"RTN","GMRAFX3",174,0)
 Q
"RTN","GMRAUTL2")
0^1^B88611028
"RTN","GMRAUTL2",1,0)
GMRAUTL2 ;SLC/DAN - New style index utilities, update utility for 120.8 ;06/01/10  07:32
"RTN","GMRAUTL2",2,0)
 ;;4.0;Adverse Reaction Tracking;**23,36,41,45**;Mar 29, 1996;Build 5
"RTN","GMRAUTL2",3,0)
 ;DBIA Section
"RTN","GMRAUTL2",4,0)
 ;%ZTLOAD    - 10063
"RTN","GMRAUTL2",5,0)
 ;DIE        - 10018
"RTN","GMRAUTL2",6,0)
 ;FILE^DIE   - 2053
"RTN","GMRAUTL2",7,0)
 ;UPDATE^DIE - 2053
"RTN","GMRAUTL2",8,0)
 ;DIQ        - 2056
"RTN","GMRAUTL2",9,0)
 ;ORCHECK    - 4859
"RTN","GMRAUTL2",10,0)
 ;ORKCHK     - 4135
"RTN","GMRAUTL2",11,0)
 ;ORQOR2     - 3458
"RTN","GMRAUTL2",12,0)
 ;ORX8       - 2467
"RTN","GMRAUTL2",13,0)
 ;PSN50P41   - 4531
"RTN","GMRAUTL2",14,0)
 ;PSN50P65   - 4543
"RTN","GMRAUTL2",15,0)
 ;XLFDT      - 10103
"RTN","GMRAUTL2",16,0)
 ;XTID       - 4631
"RTN","GMRAUTL2",17,0)
 ;
"RTN","GMRAUTL2",18,0)
 N GMRAI,GMRAC,ENTRY,UPDATED
"RTN","GMRAUTL2",19,0)
 Q:$G(X1(1))=$G(X2(1))  ;Entry unchanged
"RTN","GMRAUTL2",20,0)
 S ENTRY=DA(1)_";GMRD(120.82,"_"^"_$P(^GMRD(120.82,DA(1),0),"^")
"RTN","GMRAUTL2",21,0)
 I $G(X1(1))>0,$G(X2(1))>0 S:$G(GMRAT)="ING" GMRAI("D",X1(1))="",GMRAI("A",X2(1))="" S:$G(GMRAT)="CLASS" GMRAC("D",X1(1))="",GMRAC("A",X2(1))="" ;Edited existing entry
"RTN","GMRAUTL2",22,0)
 I $G(X1(1))>0,$G(X2(1))="" S:$G(GMRAT)="ING" GMRAI("D",X1(1))="" S:$G(GMRAT)="CLASS" GMRAC("D",X1(1))="" ;Entry deleted
"RTN","GMRAUTL2",23,0)
 I $G(X1(1))="",$G(X2(1))>0 S:$G(GMRAT)="ING" GMRAI("A",X2(1))="" S:$G(GMRAT)="CLASS" GMRAC("A",X2(1))="" ;New entry
"RTN","GMRAUTL2",24,0)
 D QUP ;Queue updating of existing entries and order checking
"RTN","GMRAUTL2",25,0)
 Q
"RTN","GMRAUTL2",26,0)
 ;
"RTN","GMRAUTL2",27,0)
QUP ;Queue the update
"RTN","GMRAUTL2",28,0)
 S ZTRTN="UPDATE^GMRAUTL2(ENTRY,.GMRAI,.GMRAC)",ZTIO="GMRA UPDATE RESOURCE",ZTDTH=$H,ZTDESC="Update existing allergies",ZTSAVE("*")="" D ^%ZTLOAD Q
"RTN","GMRAUTL2",29,0)
 ;
"RTN","GMRAUTL2",30,0)
UPDATE(ENTRY,ING,CLASS) ;Update existing entries in 120.8 with new information.
"RTN","GMRAUTL2",31,0)
 ;Entry is IEN;File reference^Text of file entry - 6;GMRD(120.82,^STRAWBERRIES
"RTN","GMRAUTL2",32,0)
 ;ING - Array of ingredients - "A",IEN for those to be added and "D",IEN for those to be deleted
"RTN","GMRAUTL2",33,0)
 ;CLASS - Array of drug classes - "A",IEN for those to be added and "D",IEN for those to be deleted
"RTN","GMRAUTL2",34,0)
 ;
"RTN","GMRAUTL2",35,0)
 N ALLERGY,POINTER,ACTION,SUB,SUBI,SUBC,DFN,GMRAS,GMRACOM
"RTN","GMRAUTL2",36,0)
 S ALLERGY=$P(ENTRY,"^",2) Q:ALLERGY=""
"RTN","GMRAUTL2",37,0)
 S POINTER=$P(ENTRY,"^") Q:POINTER=""
"RTN","GMRAUTL2",38,0)
 S SUB=0 F  S SUB=$O(^GMR(120.8,"C",ALLERGY,SUB)) Q:'+SUB  D
"RTN","GMRAUTL2",39,0)
 .S DFN=$P(^GMR(120.8,SUB,0),U)
"RTN","GMRAUTL2",40,0)
 .Q:$$DECEASED^GMRAFX(DFN)  ;Don't update if patient is deceased
"RTN","GMRAUTL2",41,0)
 .Q:$P(^GMR(120.8,SUB,0),"^",3)'=POINTER  ;Same text name but not the same entry
"RTN","GMRAUTL2",42,0)
 .Q:$G(^GMR(120.8,SUB,"ER"))>0  ;Entered in error
"RTN","GMRAUTL2",43,0)
 .S GMRACOM=0
"RTN","GMRAUTL2",44,0)
 .F ACTION="A","D" D
"RTN","GMRAUTL2",45,0)
 ..S SUBI=0 F  S SUBI=$O(ING(ACTION,SUBI)) Q:'+SUBI  D
"RTN","GMRAUTL2",46,0)
 ...I ACTION="A" D ADD("I",SUB,SUBI,.GMRAS) I $G(GMRAS) S ING(ACTION,SUBI)=1,GMRACOM=1,UPDATED(DFN)=""
"RTN","GMRAUTL2",47,0)
 ...I ACTION="D" D DEL("I",SUB,SUBI,.GMRAS) I $G(GMRAS) S ING(ACTION,SUBI)=1,GMRACOM=1
"RTN","GMRAUTL2",48,0)
 ..S SUBC=0 F  S SUBC=$O(CLASS(ACTION,SUBC)) Q:'+SUBC  D
"RTN","GMRAUTL2",49,0)
 ...I ACTION="A" D ADD("C",SUB,SUBC,.GMRAS) I $G(GMRAS) S CLASS(ACTION,SUBC)=1,UPDATED(DFN)="",GMRACOM=1
"RTN","GMRAUTL2",50,0)
 ...I ACTION="D" D DEL("C",SUB,SUBC,.GMRAS) I $G(GMRAS) S GMRACOM=1,CLASS(ACTION,SUBC)=1
"RTN","GMRAUTL2",51,0)
 .I $G(GMRACOM) D ADDCOM
"RTN","GMRAUTL2",52,0)
 I $D(UPDATED) D CHKORD ;New order checks now?
"RTN","GMRAUTL2",53,0)
 Q
"RTN","GMRAUTL2",54,0)
 ;
"RTN","GMRAUTL2",55,0)
ADD(TYPE,ALENT,SUBENT,GMRAS) ;Adds entry to appropriate multiple
"RTN","GMRAUTL2",56,0)
 N FILE,FDA,EM
"RTN","GMRAUTL2",57,0)
 S GMRAS=1
"RTN","GMRAUTL2",58,0)
 I $D(^GMR(120.8,ALENT,$S(TYPE="I":2,1:3),"B",SUBENT)) S GMRAS=0 Q  ;Entry already exists
"RTN","GMRAUTL2",59,0)
 L +^GMR(120.8,ALENT):20 I '$T Q
"RTN","GMRAUTL2",60,0)
 S FILE=$S(TYPE="I":120.802,1:120.803)
"RTN","GMRAUTL2",61,0)
 S FDA(FILE,"+1,"_ALENT_",",.01)=SUBENT
"RTN","GMRAUTL2",62,0)
 D UPDATE^DIE("","FDA",,"EM")
"RTN","GMRAUTL2",63,0)
 L -^GMR(120.8,ALENT)
"RTN","GMRAUTL2",64,0)
 Q
"RTN","GMRAUTL2",65,0)
 ;
"RTN","GMRAUTL2",66,0)
DEL(TYPE,ALENT,SUBENT,GMRAS) ;Delete entry from multiple
"RTN","GMRAUTL2",67,0)
 N FILE,FDA,EM,ENTRY
"RTN","GMRAUTL2",68,0)
 S GMRAS=1
"RTN","GMRAUTL2",69,0)
 I '$D(^GMR(120.8,ALENT,$S(TYPE="I":2,1:3),"B",SUBENT)) S GMRAS=0 Q  ;No entry to delete
"RTN","GMRAUTL2",70,0)
 L +^GMR(120.8,ALENT):20 I '$T Q
"RTN","GMRAUTL2",71,0)
 S ENTRY=$O(^GMR(120.8,ALENT,$S(TYPE="I":2,1:3),"B",SUBENT,0)) Q:'+ENTRY
"RTN","GMRAUTL2",72,0)
 S FILE=$S(TYPE="I":120.802,1:120.803)
"RTN","GMRAUTL2",73,0)
 S FDA(FILE,ENTRY_","_ALENT_",",.01)="@"
"RTN","GMRAUTL2",74,0)
 D FILE^DIE("","FDA","EM")
"RTN","GMRAUTL2",75,0)
 L -^GMR(120.8,ALENT)
"RTN","GMRAUTL2",76,0)
 Q
"RTN","GMRAUTL2",77,0)
 ;
"RTN","GMRAUTL2",78,0)
CHKORD ;Check for orders that are now in conflict with existing allergy data
"RTN","GMRAUTL2",79,0)
 N TIME,GMRAOC,ORX,SUB,GMRAORX,GI,CNT,DFN
"RTN","GMRAUTL2",80,0)
 Q:'+$G(DUZ)  ;Don't check if no valid user to send data to
"RTN","GMRAUTL2",81,0)
 K ^TMP("ORR",$J),^TMP($J,"ERR")
"RTN","GMRAUTL2",82,0)
 S DFN=0 F  S DFN=$O(UPDATED(DFN)) Q:'+DFN  D
"RTN","GMRAUTL2",83,0)
 .D EN^ORQ1(DFN_";DPT(") ;Retrieve active orders
"RTN","GMRAUTL2",84,0)
 .S TIME=$O(^TMP("ORR",$J,0))
"RTN","GMRAUTL2",85,0)
 .Q:'^TMP("ORR",$J,TIME,"TOT")  ;No orders found
"RTN","GMRAUTL2",86,0)
 .S SUB=0 F  S SUB=$O(^TMP("ORR",$J,TIME,SUB)) Q:'+SUB  D
"RTN","GMRAUTL2",87,0)
 ..D BLD^ORCHECK(+^TMP("ORR",$J,TIME,SUB)) ;Get "order" information in order checking format
"RTN","GMRAUTL2",88,0)
 .M GMRAORX=ORX K ORX,GMRAOC
"RTN","GMRAUTL2",89,0)
 .D EN^ORKCHK(.GMRAOC,DFN,.GMRAORX,"ACCEPT")
"RTN","GMRAUTL2",90,0)
 .S GI=0,CNT=0 F  S GI=$O(GMRAOC(GI)) Q:'+GI  D
"RTN","GMRAUTL2",91,0)
 ..Q:$P(GMRAOC(GI),U,2)'=3  ;Quit if not allergy related
"RTN","GMRAUTL2",92,0)
 ..;Q:$D(^OR(100,$P(GMRAOC(GI),U),9,"B",3))  ;Quit if existing allergy order check, can't be for this new information
"RTN","GMRAUTL2",93,0)
 ..Q:$$ANYARTOC^GMRAUTL2($P(GMRAOC(GI),U))  ;Quit if existing allergy order check, can't be for this new information
"RTN","GMRAUTL2",94,0)
 ..S CNT=CNT+1,^TMP($J,"ERR",DFN,CNT)=$P($$STATUS^ORQOR2($P(GMRAOC(GI),U)),U,2)_" order for "_$P($$OI^ORX8($P(GMRAOC(GI),U)),U,2)_",order #"_$P(GMRAOC(GI),U)
"RTN","GMRAUTL2",95,0)
 .K GMRAORX ;Remove previous list of orders
"RTN","GMRAUTL2",96,0)
 D MAIL K ^TMP("ORR",$J),^TMP($J,"ERR")
"RTN","GMRAUTL2",97,0)
 Q
"RTN","GMRAUTL2",98,0)
 ;
"RTN","GMRAUTL2",99,0)
ANYARTOC(GMRAIFN) ;check order to see if there are any allergy order checks
"RTN","GMRAUTL2",100,0)
 N GMRARET,GMRAI
"RTN","GMRAUTL2",101,0)
 S GMRARET=0
"RTN","GMRAUTL2",102,0)
 K ^TMP($J,"GMRAOC")
"RTN","GMRAUTL2",103,0)
 D OCAPI^ORCHECK(+GMRAIFN,"GMRAOC")
"RTN","GMRAUTL2",104,0)
 S GMRAI=0 F  S GMRAI=$O(^TMP($J,"GMRAOC",GMRAI)) Q:'GMRAI  I $G(^TMP($J,"GMRAOC",GMRAI,"OC NUMBER"))=3 S GMRARET=1
"RTN","GMRAUTL2",105,0)
 K ^TMP($J,"GMRAOC")
"RTN","GMRAUTL2",106,0)
 Q GMRARET
"RTN","GMRAUTL2",107,0)
ADDCOM ;Add comment to updated allergy indicating changes
"RTN","GMRAUTL2",108,0)
 D ADDCOM^GMRAUTL3 ;41 Moved section due to space considerations
"RTN","GMRAUTL2",109,0)
 Q
"RTN","GMRAUTL2",110,0)
 ;
"RTN","GMRAUTL2",111,0)
MAIL ;Send message containing potential order checks to user.
"RTN","GMRAUTL2",112,0)
 N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,CNT,SUB,ERR,TYPE,NUM
"RTN","GMRAUTL2",113,0)
 Q:'$D(^TMP($J,"ERR"))  ;Nothing to report
"RTN","GMRAUTL2",114,0)
 K ^TMP($J,"TEXT"),^TMP($J,"GMRAINFO") ;41 Clear out storage area
"RTN","GMRAUTL2",115,0)
 S XMDUZ="Allergy auto-update program"
"RTN","GMRAUTL2",116,0)
 S XMY($G(DUZ,.5))="" ;Send to user who initiated change or postmaster
"RTN","GMRAUTL2",117,0)
 S XMY("G.GMRA REQUEST NEW REACTANT")="" ;Include mail group to be sure someone gets this message
"RTN","GMRAUTL2",118,0)
 S CNT=1
"RTN","GMRAUTL2",119,0)
 S ^TMP($J,"TEXT",CNT)="The "_$P(ENTRY,U,2)_" reactant was updated.",CNT=CNT+1
"RTN","GMRAUTL2",120,0)
 S ^TMP($J,"TEXT",CNT)="The following drug classes and/or drug ingredients were added:",CNT=CNT+1,^TMP($J,"TEXT",CNT)="",CNT=CNT+1
"RTN","GMRAUTL2",121,0)
 F TYPE="GMRAI","GMRAC" D
"RTN","GMRAUTL2",122,0)
 .I $D(@(TYPE)) D
"RTN","GMRAUTL2",123,0)
 ..S ^TMP($J,"TEXT",CNT)=$S(TYPE="GMRAI":"Ingredients",1:"Classes")_": ",CNT=CNT+1
"RTN","GMRAUTL2",124,0)
 ..S NUM=0 F  S NUM=$O(@TYPE@("A",NUM)) Q:'+NUM  S ^TMP($J,"TEXT",CNT)=$G(^TMP($J,"TEXT",CNT))_$S($L($G(^TMP($J,"TEXT",CNT))):",",1:"") D  ;41 added call for data in structure below
"RTN","GMRAUTL2",125,0)
 ...I TYPE="GMRAI" D ZERO^PSN50P41(NUM,,$$DT^XLFDT,"GMRAINFO") ;41 ingredient call
"RTN","GMRAUTL2",126,0)
 ...I TYPE="GMRAC" D C^PSN50P65(NUM,,"GMRAINFO") ;41 drug class call
"RTN","GMRAUTL2",127,0)
 ...S ^TMP($J,"TEXT",CNT)=^TMP($J,"TEXT",CNT)_$G(^TMP($J,"GMRAINFO",NUM,.01)) ;41 add data
"RTN","GMRAUTL2",128,0)
 ..S CNT=CNT+1,^TMP($J,"TEXT",CNT)="",CNT=CNT+1
"RTN","GMRAUTL2",129,0)
 S ^TMP($J,"TEXT",CNT)="As a result of the update the following patients have drug-allergy",CNT=CNT+1
"RTN","GMRAUTL2",130,0)
 S ^TMP($J,"TEXT",CNT)="interactions that need to be reviewed to ensure the patient's safety.",CNT=CNT+1
"RTN","GMRAUTL2",131,0)
 S SUB=0 F  S SUB=$O(^TMP($J,"ERR",SUB)) Q:'+SUB  D
"RTN","GMRAUTL2",132,0)
 .S ^TMP($J,"TEXT",CNT)="",CNT=CNT+1
"RTN","GMRAUTL2",133,0)
 .S ^TMP($J,"TEXT",CNT)=$$GET1^DIQ(2,SUB_",",.01),CNT=CNT+1
"RTN","GMRAUTL2",134,0)
 .S ERR=0 F  S ERR=$O(^TMP($J,"ERR",SUB,ERR)) Q:'+ERR  S ^TMP($J,"TEXT",CNT)="   "_^TMP($J,"ERR",SUB,ERR),CNT=CNT+1
"RTN","GMRAUTL2",135,0)
 S XMTEXT="^TMP($J,""TEXT"",",XMSUB="Potential order checks from allergy update"
"RTN","GMRAUTL2",136,0)
 D ^XMD
"RTN","GMRAUTL2",137,0)
 K ^TMP($J,"TEXT")
"RTN","GMRAUTL2",138,0)
 Q
"RTN","GMRAUTL2",139,0)
 ;
"RTN","GMRAUTL2",140,0)
TOP10 ;Check top 10 reactions after push of file 120.83
"RTN","GMRAUTL2",141,0)
 N SUB,REAC,REACNO,ARRAY,SUBNM,REACNM,GMRATXT,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT
"RTN","GMRAUTL2",142,0)
 I '$L($T(SCREEN^XTID)) Q  ;No screening code so quit
"RTN","GMRAUTL2",143,0)
 S SUB=0 F  S SUB=$O(^GMRD(120.84,SUB)) Q:'+SUB  I $D(^GMRD(120.84,SUB,1)) D
"RTN","GMRAUTL2",144,0)
 .S REAC=0 F  S REAC=$O(^GMRD(120.84,SUB,1,REAC)) Q:'+REAC  D
"RTN","GMRAUTL2",145,0)
 ..S REACNO=$P(^GMRD(120.84,SUB,1,REAC,0),U) Q:'+REACNO
"RTN","GMRAUTL2",146,0)
 ..I $$SCREEN^XTID(120.83,.01,REACNO_",") D
"RTN","GMRAUTL2",147,0)
 ...S SUBNM=$P(^GMRD(120.84,SUB,0),U),REACNM=$P(^GMRD(120.83,REACNO,0),U)
"RTN","GMRAUTL2",148,0)
 ...S ARRAY(SUBNM,REACNM)=""
"RTN","GMRAUTL2",149,0)
 I $D(ARRAY) D
"RTN","GMRAUTL2",150,0)
 .S XMDUZ="Data Standardization update of file 120.83",XMY("G.GMRA REQUEST NEW REACTANT")=""
"RTN","GMRAUTL2",151,0)
 .S GMRATXT(1)="The signs/symptoms file has been automatically updated.  You're receiving"
"RTN","GMRAUTL2",152,0)
 .S GMRATXT(2)="this message because one or more signs/symptoms was inactivated during this"
"RTN","GMRAUTL2",153,0)
 .S GMRATXT(3)="update and the term(s) appear in your top ten list and must be replaced."
"RTN","GMRAUTL2",154,0)
 .S GMRATXT(4)="Below you will find the name of the site parameter and the terms that are now"
"RTN","GMRAUTL2",155,0)
 .S GMRATXT(5)="inactive for that entry.  Use the Enter/Edit Site Parameters [GMRA SITE FILE]"
"RTN","GMRAUTL2",156,0)
 .S GMRATXT(6)="option to find and replace these terms."
"RTN","GMRAUTL2",157,0)
 .S GMRATXT(7)=""
"RTN","GMRAUTL2",158,0)
 .S CNT=7
"RTN","GMRAUTL2",159,0)
 .S SUB="" F  S SUB=$O(ARRAY(SUB)) Q:SUB=""  S CNT=CNT+1,GMRATXT(CNT)="Site parameter: "_SUB D  S CNT=CNT+1,GMRATXT(CNT)=""
"RTN","GMRAUTL2",160,0)
 ..S REAC="" F  S REAC=$O(ARRAY(SUB,REAC)) Q:REAC=""  S CNT=CNT+1,GMRATXT(CNT)="Term: "_REAC
"RTN","GMRAUTL2",161,0)
 .S XMTEXT="GMRATXT(",XMSUB="Signs/symptoms require updating"
"RTN","GMRAUTL2",162,0)
 .D ^XMD
"RTN","GMRAUTL2",163,0)
 Q
"RTN","GMRAUTL2",164,0)
 ;
"RTN","GMRAUTL2",165,0)
QREACT ;Queue name update, called from "AC" xref in file 120.82.  Entire section added in patch 23
"RTN","GMRAUTL2",166,0)
 N OTERM,NTERM,ZTRTN,ZTDTH,ZTIO,ZTDESC
"RTN","GMRAUTL2",167,0)
 Q:X1(1)=""!(X2(1)="")  ;Entry is new or has been deleted, no updating required
"RTN","GMRAUTL2",168,0)
 Q:X1(1)=X2(1)  ;Entry has been updated to same value, no updating required
"RTN","GMRAUTL2",169,0)
 S OTERM=X1(1),NTERM=X2(1)
"RTN","GMRAUTL2",170,0)
 S ZTRTN="REACT^GMRAUTL2",ZTIO="GMRA UPDATE RESOURCE",ZTDTH=$H,ZTDESC="UPDATE REACTANT FIELD IN 120.8",ZTSAVE("*")="" D ^%ZTLOAD
"RTN","GMRAUTL2",171,0)
 Q
"RTN","GMRAUTL2",172,0)
 ;
"RTN","GMRAUTL2",173,0)
REACT ;Update REACTANT field with name from 120.82.  Section added with patch 23
"RTN","GMRAUTL2",174,0)
 N IEN,FDA,EM,DFN
"RTN","GMRAUTL2",175,0)
 S IEN=0 F  S IEN=$O(^GMR(120.8,"C",OTERM,IEN)) Q:'+IEN  D
"RTN","GMRAUTL2",176,0)
 .S DFN=$P(^GMR(120.8,IEN,0),U)
"RTN","GMRAUTL2",177,0)
 .Q:$$DECEASED^GMRAFX(DFN)  ;Don't update if patient is deceased
"RTN","GMRAUTL2",178,0)
 .Q:+$G(^GMR(120.8,IEN,"ER"))  ;Don't update if entered in error
"RTN","GMRAUTL2",179,0)
 .L +^GMR(120.8,IEN):20 I '$T Q
"RTN","GMRAUTL2",180,0)
 .S FDA(120.8,IEN_",",.02)=NTERM
"RTN","GMRAUTL2",181,0)
 .D FILE^DIE("","FDA","EM")
"RTN","GMRAUTL2",182,0)
 .L -^GMR(120.8,IEN)
"RTN","GMRAUTL2",183,0)
 Q
"RTN","GMRAUTL2",184,0)
 ;
"RTN","GMRAUTL2",185,0)
QTYPE ;Queue allergy type updates, section added in 36
"RTN","GMRAUTL2",186,0)
 N ENTRY
"RTN","GMRAUTL2",187,0)
 S ENTRY=DA_";GMRD(120.82,"_"^"_$P(^GMRD(120.82,DA,0),"^")
"RTN","GMRAUTL2",188,0)
 Q:X1(1)=""!(X2(1)="")
"RTN","GMRAUTL2",189,0)
 Q:X1(1)=X2(1)
"RTN","GMRAUTL2",190,0)
 S ZTRTN="TYPE^GMRAUTL2",ZTIO="",ZTDTH=$H,ZTDESC="Allergy type updates",ZTSAVE("*")="" D ^%ZTLOAD
"RTN","GMRAUTL2",191,0)
 Q
"RTN","GMRAUTL2",192,0)
 ;
"RTN","GMRAUTL2",193,0)
TYPE ;Find related entries in 120.8 and update, section added in 36
"RTN","GMRAUTL2",194,0)
 N ALLERGY,POINTER,DFN,SUB
"RTN","GMRAUTL2",195,0)
 S ALLERGY=$P(ENTRY,"^",2) Q:ALLERGY=""
"RTN","GMRAUTL2",196,0)
 S POINTER=$P(ENTRY,"^") Q:POINTER=""
"RTN","GMRAUTL2",197,0)
 S SUB=0 F  S SUB=$O(^GMR(120.8,"C",ALLERGY,SUB)) Q:'+SUB  D
"RTN","GMRAUTL2",198,0)
 .Q:$P(^GMR(120.8,SUB,0),"^",3)'=POINTER  ;Same text name but not the same entry
"RTN","GMRAUTL2",199,0)
 .S DFN=$P(^GMR(120.8,SUB,0),U)
"RTN","GMRAUTL2",200,0)
 .Q:$$DECEASED^GMRAFX(DFN)  ;Don't update if patient is deceased
"RTN","GMRAUTL2",201,0)
 .Q:$G(^GMR(120.8,SUB,"ER"))>0  ;Entered in error
"RTN","GMRAUTL2",202,0)
 .S DR="3.1///"_X2(1),DIE=120.8,DA=SUB D ^DIE ;Update allergy type
"RTN","GMRAUTL2",203,0)
 Q
"VER")
8.0^22.0
**INSTALL NAME**
GMRC*3.0*66
"BLD",19523,0)
GMRC*3.0*66^CONSULT/REQUEST TRACKING^0^3110210^y
"BLD",19523,1,0)
^^1^1^3081120^
"BLD",19523,1,1,0)
GMRC changes in support of CPRS GUI v28
"BLD",19523,4,0)
^9.64PA^123^1
"BLD",19523,4,123,0)
123
"BLD",19523,4,123,2,0)
^9.641^123^1
"BLD",19523,4,123,2,123,0)
REQUEST/CONSULTATION  (File-top level)
"BLD",19523,4,123,2,123,1,0)
^9.6411^17^1
"BLD",19523,4,123,2,123,1,17,0)
EARLIEST DATE
"BLD",19523,4,123,222)
y^n^p^^^^n^^n
"BLD",19523,4,123,224)

"BLD",19523,4,"APDD",123,123)

"BLD",19523,4,"APDD",123,123,17)

"BLD",19523,4,"B",123,123)

"BLD",19523,6)
6^
"BLD",19523,6.3)
30
"BLD",19523,"ABPKG")
n
"BLD",19523,"KRN",0)
^9.67PA^779.2^20
"BLD",19523,"KRN",.4,0)
.4
"BLD",19523,"KRN",.401,0)
.401
"BLD",19523,"KRN",.402,0)
.402
"BLD",19523,"KRN",.403,0)
.403
"BLD",19523,"KRN",.5,0)
.5
"BLD",19523,"KRN",.84,0)
.84
"BLD",19523,"KRN",3.6,0)
3.6
"BLD",19523,"KRN",3.8,0)
3.8
"BLD",19523,"KRN",9.2,0)
9.2
"BLD",19523,"KRN",9.8,0)
9.8
"BLD",19523,"KRN",9.8,"NM",0)
^9.68A^20^20
"BLD",19523,"KRN",9.8,"NM",1,0)
GMRCHL7^^0^B31393339
"BLD",19523,"KRN",9.8,"NM",2,0)
GMRCHL7A^^0^B29763566
"BLD",19523,"KRN",9.8,"NM",3,0)
GMRCHL7B^^0^B26577242
"BLD",19523,"KRN",9.8,"NM",4,0)
GMRCHL7U^^0^B26417808
"BLD",19523,"KRN",9.8,"NM",5,0)
GMRCIAC1^^0^B69544228
"BLD",19523,"KRN",9.8,"NM",6,0)
GMRCIACT^^0^B61170306
"BLD",19523,"KRN",9.8,"NM",7,0)
GMRCISEG^^0^B31263657
"BLD",19523,"KRN",9.8,"NM",8,0)
GMRCP5B^^0^B37235428
"BLD",19523,"KRN",9.8,"NM",9,0)
GMRCSLM2^^0^B77652080
"BLD",19523,"KRN",9.8,"NM",10,0)
GMRCP5D^^0^B71660490
"BLD",19523,"KRN",9.8,"NM",11,0)
GMRCISG1^^0^B28005109
"BLD",19523,"KRN",9.8,"NM",12,0)
GMRCGUIC^^0^B55896800
"BLD",19523,"KRN",9.8,"NM",13,0)
GMRCGUIU^^0^B30098345
"BLD",19523,"KRN",9.8,"NM",14,0)
GMRCEDIT^^0^B12257159
"BLD",19523,"KRN",9.8,"NM",15,0)
GMRCEDT1^^0^B51689293
"BLD",19523,"KRN",9.8,"NM",16,0)
GMRCEDT2^^0^B18295173
"BLD",19523,"KRN",9.8,"NM",17,0)
GMRCEDT3^^0^B17640061
"BLD",19523,"KRN",9.8,"NM",18,0)
GMRCEDT4^^0^B81417633
"BLD",19523,"KRN",9.8,"NM",19,0)
GMRCIAC2^^0^B38779618
"BLD",19523,"KRN",9.8,"NM",20,0)
GMRCSTL8^^0^B111506461
"BLD",19523,"KRN",9.8,"NM","B","GMRCEDIT",14)

"BLD",19523,"KRN",9.8,"NM","B","GMRCEDT1",15)

"BLD",19523,"KRN",9.8,"NM","B","GMRCEDT2",16)

"BLD",19523,"KRN",9.8,"NM","B","GMRCEDT3",17)

"BLD",19523,"KRN",9.8,"NM","B","GMRCEDT4",18)

"BLD",19523,"KRN",9.8,"NM","B","GMRCGUIC",12)

"BLD",19523,"KRN",9.8,"NM","B","GMRCGUIU",13)

"BLD",19523,"KRN",9.8,"NM","B","GMRCHL7",1)

"BLD",19523,"KRN",9.8,"NM","B","GMRCHL7A",2)

"BLD",19523,"KRN",9.8,"NM","B","GMRCHL7B",3)

"BLD",19523,"KRN",9.8,"NM","B","GMRCHL7U",4)

"BLD",19523,"KRN",9.8,"NM","B","GMRCIAC1",5)

"BLD",19523,"KRN",9.8,"NM","B","GMRCIAC2",19)

"BLD",19523,"KRN",9.8,"NM","B","GMRCIACT",6)

"BLD",19523,"KRN",9.8,"NM","B","GMRCISEG",7)

"BLD",19523,"KRN",9.8,"NM","B","GMRCISG1",11)

"BLD",19523,"KRN",9.8,"NM","B","GMRCP5B",8)

"BLD",19523,"KRN",9.8,"NM","B","GMRCP5D",10)

"BLD",19523,"KRN",9.8,"NM","B","GMRCSLM2",9)

"BLD",19523,"KRN",9.8,"NM","B","GMRCSTL8",20)

"BLD",19523,"KRN",19,0)
19
"BLD",19523,"KRN",19.1,0)
19.1
"BLD",19523,"KRN",101,0)
101
"BLD",19523,"KRN",409.61,0)
409.61
"BLD",19523,"KRN",771,0)
771
"BLD",19523,"KRN",779.2,0)
779.2
"BLD",19523,"KRN",870,0)
870
"BLD",19523,"KRN",8989.51,0)
8989.51
"BLD",19523,"KRN",8989.52,0)
8989.52
"BLD",19523,"KRN",8994,0)
8994
"BLD",19523,"KRN","B",.4,.4)

"BLD",19523,"KRN","B",.401,.401)

"BLD",19523,"KRN","B",.402,.402)

"BLD",19523,"KRN","B",.403,.403)

"BLD",19523,"KRN","B",.5,.5)

"BLD",19523,"KRN","B",.84,.84)

"BLD",19523,"KRN","B",3.6,3.6)

"BLD",19523,"KRN","B",3.8,3.8)

"BLD",19523,"KRN","B",9.2,9.2)

"BLD",19523,"KRN","B",9.8,9.8)

"BLD",19523,"KRN","B",19,19)

"BLD",19523,"KRN","B",19.1,19.1)

"BLD",19523,"KRN","B",101,101)

"BLD",19523,"KRN","B",409.61,409.61)

"BLD",19523,"KRN","B",771,771)

"BLD",19523,"KRN","B",779.2,779.2)

"BLD",19523,"KRN","B",870,870)

"BLD",19523,"KRN","B",8989.51,8989.51)

"BLD",19523,"KRN","B",8989.52,8989.52)

"BLD",19523,"KRN","B",8994,8994)

"BLD",19523,"QUES",0)
^9.62^^
"BLD",19523,"REQB",0)
^9.611^4^3
"BLD",19523,"REQB",2,0)
GMRC*3.0*58^2
"BLD",19523,"REQB",3,0)
GMRC*3.0*60^2
"BLD",19523,"REQB",4,0)
GMRC*3.0*68^2
"BLD",19523,"REQB","B","GMRC*3.0*58",2)

"BLD",19523,"REQB","B","GMRC*3.0*60",3)

"BLD",19523,"REQB","B","GMRC*3.0*68",4)

"FIA",123)
REQUEST/CONSULTATION
"FIA",123,0)
^GMR(123,
"FIA",123,0,0)
123DI
"FIA",123,0,1)
y^n^p^^^^n^^n
"FIA",123,0,10)

"FIA",123,0,11)

"FIA",123,0,"RLRO")

"FIA",123,0,"VR")
3.0^GMRC
"FIA",123,123)
1
"FIA",123,123,17)

"MBREQ")
1
"PKG",66,-1)
1^1
"PKG",66,0)
CONSULT/REQUEST TRACKING^GMRC^CONSULTS/REQUESTS
"PKG",66,20,0)
^9.402P^^
"PKG",66,22,0)
^9.49I^1^1
"PKG",66,22,1,0)
3.0^2980101^2980204^64
"PKG",66,22,1,"PAH",1,0)
66^3110210^1392
"PKG",66,22,1,"PAH",1,1,0)
^^1^1^3110210
"PKG",66,22,1,"PAH",1,1,1,0)
GMRC changes in support of CPRS GUI v28
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
20
"RTN","GMRCEDIT")
0^14^B12257159
"RTN","GMRCEDIT",1,0)
GMRCEDIT ;SLC/DCM,JFR - EDIT CANCELLED CONSULT-MAIN DRIVER ;04/23/09  11:36
"RTN","GMRCEDIT",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,10,18,47,66**;DEC 27, 1997;Build 30
"RTN","GMRCEDIT",3,0)
 ; Patch 18 newed variable DFN and added line tag VALPROV
"RTN","GMRCEDIT",4,0)
 ; This routine invokes IA #2638 (^ORD(100.01), #2713 (ORB3F1), #10060 (access ^VA(200))
"RTN","GMRCEDIT",5,0)
 ;#2690 (ORB3FUP1), #10118 (EN^VAML), #10117 (SET^VAML10), #10102 (XQORM1), #10026 (DIR), #2056 (GET1^DIQ)
"RTN","GMRCEDIT",6,0)
EN(XQCON,XQDFN) ; -- main entry point for GMRCEDIT
"RTN","GMRCEDIT",7,0)
 ;XQDFN=XQAID   XQCON=XQADATA from CPRS alerts
"RTN","GMRCEDIT",8,0)
 N GMRCNOTF,GMRCCORY,GMRCDA,GMRCO,DFN
"RTN","GMRCEDIT",9,0)
 S DFN=$P(XQDFN,",",2),GMRCDA=$S(XQCON=+XQCON:+XQCON,+$P($P(XQCON,",",2),";",2):+$P($P(XQCON,",",2),";",2),XQCON?1N.N1",GMRC".E:+XQCON,1:$P($P(XQCON,";",3),",",1))
"RTN","GMRCEDIT",10,0)
 S GMRCNOTF=+$P(XQDFN,",",3)
"RTN","GMRCEDIT",11,0)
 I '+GMRCDA S XQAKILL=$$XQAKILL^ORB3F1(GMRCNOTF) D DEL^ORB3FUP1(.GMRCCORY,XQDFN),END Q
"RTN","GMRCEDIT",12,0)
 S GMRCDAP=GMRCDA
"RTN","GMRCEDIT",13,0)
 I '$$LOCK^GMRCA1(+GMRCDAP) D END Q
"RTN","GMRCEDIT",14,0)
 N GMRCLCK S GMRCLCK=1 ;JFR
"RTN","GMRCEDIT",15,0)
 ;S GMRCDAP=GMRCDA I +$P(^GMR(123,+GMRCDA,0),"^",5)
"RTN","GMRCEDIT",16,0)
 S GMRCOK=$P(^ORD(100.01,$P(^GMR(123,+GMRCDA,0),"^",12),0),"^",1),GMRCOK=$S(GMRCOK["CANCELLED":1,1:0)
"RTN","GMRCEDIT",17,0)
 I '$D(GMRCOK) S XQAKILL=$$XQAKILL^ORB3F1(GMRCNOTF) D DEL^ORB3FUP1(.GMRCCORY,XQDFN),END Q
"RTN","GMRCEDIT",18,0)
 S GMRCPNM=$P(^DPT(DFN,0),"^",1)
"RTN","GMRCEDIT",19,0)
 S GMRCPROV=$P($G(^GMR(123,GMRCDA,0)),"^",14) I 'GMRCPROV S GMRCPROV=$P($G(^GMR(123,GMRCDA,12)),"^",6)
"RTN","GMRCEDIT",20,0)
 I +GMRCPROV S GMRCPROV=$$GET1^DIQ(200,GMRCPROV,.01) ;wat/66 replaced direct read of ^VA(200
"RTN","GMRCEDIT",21,0)
 D EN^VALM("GMRC EDIT CONSULT")  ;********* CALL TO LIST MANAGER
"RTN","GMRCEDIT",22,0)
 I $S($O(GMRCED(0)):1,$D(^TMP("GMRCED",$J)):1,1:0),'$D(GMRCRSUB) D
"RTN","GMRCEDIT",23,0)
 . N DIR,DTOUT,DUOUT,X,Y
"RTN","GMRCEDIT",24,0)
 . W !,$C(7),"This Consult Has Not Been Resubmitted!!"
"RTN","GMRCEDIT",25,0)
 . W !,"Resubmit Or All Edits Will Be Lost!!",!!
"RTN","GMRCEDIT",26,0)
 . S DIR(0)="Y",DIR("A")="Do you wish to resubmit now? ",DIR("B")="YES"
"RTN","GMRCEDIT",27,0)
 . D ^DIR I $D(DUOUT)!($D(DTOUT))!(Y<1) W !!,"No changes made!" Q
"RTN","GMRCEDIT",28,0)
 . D EN^GMRCEDT2(GMRCDAP)
"RTN","GMRCEDIT",29,0)
 . Q
"RTN","GMRCEDIT",30,0)
 S XQAKILL=$$XQAKILL^ORB3F1(GMRCNOTF) D DEL^ORB3FUP1(.GMRCCORY,XQDFN)
"RTN","GMRCEDIT",31,0)
 D END
"RTN","GMRCEDIT",32,0)
 Q
"RTN","GMRCEDIT",33,0)
 ;
"RTN","GMRCEDIT",34,0)
HDR ; -- header code
"RTN","GMRCEDIT",35,0)
 S VALMHDR(1)="Edit Consult for Patient "_GMRCPNM_"  Consult Number: "_GMRCDA
"RTN","GMRCEDIT",36,0)
 S VALMHDR(2)="Sending Provider: "_GMRCPROV
"RTN","GMRCEDIT",37,0)
 Q
"RTN","GMRCEDIT",38,0)
 ;
"RTN","GMRCEDIT",39,0)
INIT ; -- init variables and list array
"RTN","GMRCEDIT",40,0)
 K ^TMP("GMRCR",$J,"EDLIST")
"RTN","GMRCEDIT",41,0)
 S DSPLINE=0,DATA="",VALMAR="^TMP(""GMRCR"",$J,""EDLIST"")"
"RTN","GMRCEDIT",42,0)
 F LINE=1:1:GMRCLNO S DSPLINE=$O(^TMP("GMRCR",$J,"ED",DSPLINE)) Q:DSPLINE=""!(DSPLINE?1A.E)  S DATA=^(DSPLINE,0) D SET^VALM10(LINE,DATA)
"RTN","GMRCEDIT",43,0)
 S VALMCNT=GMRCLNO,VALMPGE=1,XQORM("A")="Select Action: "
"RTN","GMRCEDIT",44,0)
 K DSPLINE,DATA,LINE
"RTN","GMRCEDIT",45,0)
 Q
"RTN","GMRCEDIT",46,0)
 ;
"RTN","GMRCEDIT",47,0)
HELP ; -- help code
"RTN","GMRCEDIT",48,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","GMRCEDIT",49,0)
 Q
"RTN","GMRCEDIT",50,0)
 ;
"RTN","GMRCEDIT",51,0)
VALPROV(GMRCIEN) ; Check Provider or Update authority.
"RTN","GMRCEDIT",52,0)
 I DUZ=$P(^GMR(123,+GMRCIEN,0),"^",14) Q 1
"RTN","GMRCEDIT",53,0)
 I $$VALID^GMRCAU($P(^GMR(123,+GMRCIEN,0),"^",5)) Q 1
"RTN","GMRCEDIT",54,0)
 Q 0
"RTN","GMRCEDIT",55,0)
EXIT ;
"RTN","GMRCEDIT",56,0)
 ;Don't kill anything here
"RTN","GMRCEDIT",57,0)
 Q
"RTN","GMRCEDIT",58,0)
END ; -- exit code
"RTN","GMRCEDIT",59,0)
 I $G(GMRCLCK) D UNLOCK^GMRCA1(+GMRCDAP) ;JFR
"RTN","GMRCEDIT",60,0)
 K ^TMP("GMRCR",$J,"EDLIST"),^TMP("GMRCR",$J,"ED")
"RTN","GMRCEDIT",61,0)
 K ^TMP("GMRCED",$J),^TMP("GMRCSUB",$J),^TMP("GMRCFLD20",$J)
"RTN","GMRCEDIT",62,0)
 K CMDA,DFN,DIC,DIE,DR,DA,FLDA,FLDNM,GMRCA,GMRCATN,GMRCD,GMRCDD,GMRCANS,GMRCDIAG,GMRCED,GMRCEDCM,GMRCIND,GMRCINO,GMRCKEEP,GMRCLNO,GMRCND,GMRCND1,GMRCO,GMRCOK,GMRCPC,GMRCPL,GMRCPR,GMRCPNM,GMRCPROC,GMRCPROV,GMRCREQ,GMRCRQT
"RTN","GMRCEDIT",63,0)
 K GMRCFLD,GMRCOUNT,GMRCRSUB,GMRCSS,GMRCURG,GMRCDA,GMRCDAP,GMRCDA1,ND,TRKDA,XQAKILL,GMRCERDT
"RTN","GMRCEDIT",64,0)
 Q
"RTN","GMRCEDIT",65,0)
 ;
"RTN","GMRCEDIT",66,0)
EXPND ; -- expand code
"RTN","GMRCEDIT",67,0)
 Q
"RTN","GMRCEDIT",68,0)
 ;
"RTN","GMRCEDT1")
0^15^B51689293
"RTN","GMRCEDT1",1,0)
GMRCEDT1 ;SLC/DCM,JFR - EDIT A CONSULT AND RE-SEND AS NEW ;08/20/09  12:16
"RTN","GMRCEDT1",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,47,66**;DEC 27, 1997;Build 30
"RTN","GMRCEDT1",3,0)
 ;
"RTN","GMRCEDT1",4,0)
 ; This routine invokes IA #2638 (^ORD(100.01,), #3991 (ICDAPIU), #10117 (VALM10)
"RTN","GMRCEDT1",5,0)
 ;                         #10103 (XLFDT), #10104 (XLFSTR), #10060 (access ^VA(200)), #2056 (GET1^DIQ)
"RTN","GMRCEDT1",6,0)
 ;
"RTN","GMRCEDT1",7,0)
EN(GMRCO) ;GMRCO=IEN of consult from file 123
"RTN","GMRCEDT1",8,0)
 ;GMRCSS=To Service   GMRCPROC=Procedure Request Type
"RTN","GMRCEDT1",9,0)
 ;GMRCURG=Urgency     GMRCPL=Place Of Consultation
"RTN","GMRCEDT1",10,0)
 ;GMRCATN=Attention   GMRCINO=Service is In/Out Patient
"RTN","GMRCEDT1",11,0)
 ;GMRCPNM=Patient Name  GMRCDIAG=Provisional Diagnosis
"RTN","GMRCEDT1",12,0)
 ;GMRCERDT=Earliest Appr. Date
"RTN","GMRCEDT1",13,0)
 ;GMRCPROS=Prosthetics Service y/n
"RTN","GMRCEDT1",14,0)
 N GMRCSS,GMRCPROC,GMRCURG,GMRCPL,GMRCATN,GMRCINO,GMRCDIAG,LN,GMRCRESP,GMRCERDT,GMRCPROS,IDX
"RTN","GMRCEDT1",15,0)
 K ^TMP("GMRCR",$J,"ED") S GMRCLNO=1
"RTN","GMRCEDT1",16,0)
 I $L($P(^GMR(123,+GMRCO,0),"^",12)) S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="  CURRENT STATUS: (Not Editable): "_$P(^ORD(100.01,$P(^(0),"^",12),0),"^",1),GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",17,0)
 S GMRCD=0 F  S GMRCD=$O(^GMR(123,+GMRCO,40,"B",GMRCD)) Q:'GMRCD  S GMRCDD="" F  S GMRCDD=$O(^GMR(123,GMRCO,40,"B",GMRCD,GMRCDD)) Q:'GMRCDD  D
"RTN","GMRCEDT1",18,0)
 .I $P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",2)=19 S LN=0 D
"RTN","GMRCEDT1",19,0)
 ..N GMRCPERS,GMRCTX
"RTN","GMRCEDT1",20,0)
 ..I '$D(^GMR(123,+GMRCO,12)) D
"RTN","GMRCEDT1",21,0)
 ...S GMRCPERS=+$P($G(^GMR(123,+GMRCO,40,GMRCDD,0)),"^",5)
"RTN","GMRCEDT1",22,0)
 ...S GMRCPERS=$$GET1^DIQ(200,GMRCPERS,.01)
"RTN","GMRCEDT1",23,0)
 ..I $D(^GMR(123,+GMRCO,12)) D
"RTN","GMRCEDT1",24,0)
 ...I $P(^GMR(123,+GMRCO,12),U,5)="P" D
"RTN","GMRCEDT1",25,0)
 ....S GMRCPERS=$P($G(^GMR(123,+GMRCO,40,GMRCDD,2)),U,1)
"RTN","GMRCEDT1",26,0)
 ...I $P(^GMR(123,+GMRCO,12),U,5)="F" D
"RTN","GMRCEDT1",27,0)
 ....S GMRCPERS=$P($G(^GMR(123,+GMRCO,40,GMRCDD,0)),U,5)
"RTN","GMRCEDT1",28,0)
 ....S GMRCPERS=$$GET1^DIQ(200,GMRCPERS,.01)
"RTN","GMRCEDT1",29,0)
 ..S GMRCTX="  CANCELLED BY (Not Editable): "_GMRCPERS
"RTN","GMRCEDT1",30,0)
 ..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=GMRCTX,GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",31,0)
 ..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="  CANCELLED COMMENT (Not Editable):",GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",32,0)
 ..S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E)  I $L(^GMR(123,+GMRCO,40,GMRCDD,1,LN,0))>75 S FLG=1 D WPSET^GMRCUTIL("^GMR(123,+GMRCO,40,GMRCDD,1)","^TMP(""GMRCR"",$J,""ED"")","",.GMRCLNO,"",FLG)
"RTN","GMRCEDT1",33,0)
 ..I '$D(FLG) S LN=0 F  S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E)  S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^(LN,0),GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",34,0)
 ..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="",$P(^(0),"-",79)=""
"RTN","GMRCEDT1",35,0)
 ..S GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",36,0)
 ..Q
"RTN","GMRCEDT1",37,0)
 .Q
"RTN","GMRCEDT1",38,0)
 S GMRCSS=$S($D(GMRCEDT(1)):GMRCEDT(1),1:$P(^GMR(123,+GMRCO,0),"^",5)_U_$P(^GMR(123.5,$P(^GMR(123,+GMRCO,0),"^",5),0),U))
"RTN","GMRCEDT1",39,0)
 S GMRCPROC=$S($D(GMRCED(1)):GMRCED(1),1:$P(^GMR(123,+GMRCO,0),"^",8)_U_$$GET1^DIQ(123.3,+$P(^GMR(123,+GMRCO,0),"^",8),.01))
"RTN","GMRCEDT1",40,0)
 I $D(GMRCED(2)) S GMRCINO=GMRCED(2)
"RTN","GMRCEDT1",41,0)
 I '$D(GMRCINO) S GMRCINO=$P(^GMR(123,+GMRCO,0),U,18)_U_$S($P(^(0),U,18)="I":"Inpatient",1:"Outpatient")
"RTN","GMRCEDT1",42,0)
 S GMRCURG=$S($D(GMRCED(3)):GMRCED(3),1:$P(^GMR(123,+GMRCO,0),"^",9)_U_$$GET1^DIQ(101,+$P(^(0),"^",9),1))
"RTN","GMRCEDT1",43,0)
 S GMRCPL=$S($D(GMRCED(4)):GMRCED(4),1:$P(^GMR(123,+GMRCO,0),"^",10)_U_$$GET1^DIQ(101,+$P(^(0),U,10),1))
"RTN","GMRCEDT1",44,0)
 S GMRCPROS=$G(^GMR(123.5,$P(GMRCSS,U),"INT")) I $G(GMRCPROS)="" D
"RTN","GMRCEDT1",45,0)
 .S GMRCERDT=$S($D(GMRCED(5)):GMRCED(5),1:$P(^GMR(123,+GMRCO,0),"^",24)_U_$$FMTE^XLFDT($P(^GMR(123,GMRCO,0),U,24)))
"RTN","GMRCEDT1",46,0)
 S GMRCATN=$S($D(GMRCED(6)):GMRCED(6),1:$P(^GMR(123,+GMRCO,0),"^",11)_U_$$GET1^DIQ(200,+$P(^(0),U,11),.01))
"RTN","GMRCEDT1",47,0)
 I '$D(^GMR(123,GMRCO,30.1)) D
"RTN","GMRCEDT1",48,0)
 . I $D(GMRCED(7)),$L($P(GMRCED(7),U,2)) D  Q
"RTN","GMRCEDT1",49,0)
 .. S GMRCDIAG=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"
"RTN","GMRCEDT1",50,0)
 . S GMRCDIAG=$S($D(GMRCED(7)):GMRCED(7),1:$G(^GMR(123,+GMRCO,30)))
"RTN","GMRCEDT1",51,0)
 I $D(^GMR(123,GMRCO,30.1)) D
"RTN","GMRCEDT1",52,0)
 . I $D(GMRCED(7)),$L(GMRCED(7)) D  Q
"RTN","GMRCEDT1",53,0)
 .. S GMRCDIAG=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"
"RTN","GMRCEDT1",54,0)
 . S GMRCDIAG=$G(^GMR(123,+GMRCO,30))
"RTN","GMRCEDT1",55,0)
 . I '$$STATCHK^ICDAPIU(^GMR(123,GMRCO,30.1),DT) D
"RTN","GMRCEDT1",56,0)
 .. S GMRCDIAG=GMRCDIAG_"   <INACTIVE CODE>"
"RTN","GMRCEDT1",57,0)
 S GMRCREQ=$S(+$P(^GMR(123,+GMRCO,0),U,17)="P":"Procedure",1:"Consult")
"RTN","GMRCEDT1",58,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="SENDING PROVIDER (Not Editable): "_$S($P($G(^GMR(123,+GMRCO,12)),U,6):$P(^GMR(123,+GMRCO,12),U,6),$P(^GMR(123,+GMRCO,0),"^",14):$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),"^",14),.01),1:"UNKNOWN"),GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",59,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="REQUEST TYPE (Not Editable): "_GMRCREQ,GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",60,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=$$REPEAT^XLFSTR("-",79),GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",61,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="  TO SERVICE (Not Editable): "_$P(GMRCSS,U,2) S GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",62,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=" ",GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",63,0)
 S IDX=1,^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PROCEDURE: "_$P(GMRCPROC,U,2)
"RTN","GMRCEDT1",64,0)
 D:+GMRCPROC RVRS(GMRCLNO,$D(GMRCED(IDX))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",65,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" Performed as INPT OR OUTPT: "_$P(GMRCINO,U,2) D RVRS(GMRCLNO,$D(GMRCED(2))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",66,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" URGENCY: "_$P(GMRCURG,U,2) D RVRS(GMRCLNO,$D(GMRCED(3))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",67,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PLACE OF CONSULTATION: "_$P(GMRCPL,U,2) D RVRS(GMRCLNO,$D(GMRCED(4))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",68,0)
 I $G(GMRCPROS)="" S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" EARLIEST APPROPRIATE DATE: "_$P(GMRCERDT,U,2) D RVRS(GMRCLNO,$D(GMRCED(5))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",69,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" ATTENTION (CONSULTANT): "_$P(GMRCATN,U,2) D RVRS(GMRCLNO,$D(GMRCED(6))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",70,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" PROVISIONAL DIAGNOSIS: "_GMRCDIAG D RVRS(GMRCLNO,$D(GMRCED(7))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1
"RTN","GMRCEDT1",71,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" REASON FOR REQUEST:" D RVRS(GMRCLNO,$D(^TMP("GMRCED",$J,20))) S GMRCLNO=GMRCLNO+1,IDX=IDX+1 D
"RTN","GMRCEDT1",72,0)
 . I $D(^TMP("GMRCED",$J,20)) D  Q
"RTN","GMRCEDT1",73,0)
 .. N ND S ND=0
"RTN","GMRCEDT1",74,0)
 .. F  S ND=$O(^TMP("GMRCED",$J,20,ND)) Q:'ND  D
"RTN","GMRCEDT1",75,0)
 ... D KILL^VALM10(GMRCLNO)
"RTN","GMRCEDT1",76,0)
 ... S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCED",$J,20,ND,0)
"RTN","GMRCEDT1",77,0)
 ... S GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",78,0)
 . N ND S ND=0
"RTN","GMRCEDT1",79,0)
 . F  S ND=$O(^GMR(123,+GMRCO,20,ND)) Q:ND=""  D
"RTN","GMRCEDT1",80,0)
 .. S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^GMR(123,+GMRCO,20,ND,0)
"RTN","GMRCEDT1",81,0)
 .. S GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",82,0)
 .Q
"RTN","GMRCEDT1",83,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="",GMRCLNO=GMRCLNO+1,^TMP("GMRCR",$J,"ED",GMRCLNO,0)=IDX_" COMMENT(S): (Add Only)" D RVRS(GMRCLNO) S GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",84,0)
 I $D(^TMP("GMRCED",$J,40)) D
"RTN","GMRCEDT1",85,0)
 . D KILL^VALM10(GMRCLNO)
"RTN","GMRCEDT1",86,0)
 . S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="  New Comment:",GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",87,0)
 . N ND S ND=0 F  S ND=$O(^TMP("GMRCED",$J,40,ND)) Q:'ND  D
"RTN","GMRCEDT1",88,0)
 .. S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCED",$J,40,ND,0)
"RTN","GMRCEDT1",89,0)
 .. S GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",90,0)
 N GMRCEDCT
"RTN","GMRCEDT1",91,0)
 S GMRCD=0,GMRCEDCT=0 F  S GMRCD=$O(^GMR(123,+GMRCO,40,"B",GMRCD)) Q:'GMRCD  S GMRCDD="",GMRCDD=$O(^GMR(123,+GMRCO,40,"B",GMRCD,GMRCDD)) Q:'GMRCDD  D
"RTN","GMRCEDT1",92,0)
 .I $P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",2)=20 S LN=0,GMRCEDCT=GMRCEDCT+1,GMRCEDCM(GMRCEDCT)=GMRCDD D
"RTN","GMRCEDT1",93,0)
 ..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)="",GMRCLNO=GMRCLNO+1,^TMP("GMRCR",$J,"ED",GMRCLNO,0)="ADDED COMMENT (Not Editable) Entered: "_$P($$FMTE^XLFDT($P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",1)),"@",1)
"RTN","GMRCEDT1",94,0)
 ..S GMRCRESP=$S($L($P($G(^GMR(123,+GMRCO,40,GMRCDD,0)),"^",5)):$$GET1^DIQ(200,$P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",5),.01),$L($P($G(^GMR(123,+GMRCO,40,GMRCDD,2)),"^",1)):$P(^GMR(123,+GMRCO,40,GMRCDD,2),"^",1),1:"UNKNOWN")
"RTN","GMRCEDT1",95,0)
 ..S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCR",$J,"ED",GMRCLNO,0)_" BY: "_GMRCRESP,GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",96,0)
 ..;S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^TMP("GMRCR",$J,"ED",GMRCLNO,0)_" BY: "_$S($L($P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",4)):$P(^VA(200,$P(^GMR(123,+GMRCO,40,GMRCDD,0),"^",4),0),"^",1),1:"UNKNOWN"),GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",97,0)
 ..S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E)  I $L(^GMR(123,+GMRCO,40,GMRCDD,1,LN,0))>75 S FLG=1 D WPSET^GMRCUTIL("^GMR(123,+GMRCO,40,GMRCDD,1)","^TMP(""GMRCR"",$J,""ED"")","",.GMRCLNO,"",FLG) Q
"RTN","GMRCEDT1",98,0)
 ..S LN=0 F  S LN=$O(^GMR(123,+GMRCO,40,GMRCDD,1,LN)) Q:LN=""!(LN?1A.E)  S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=^(LN,0),GMRCLNO=GMRCLNO+1
"RTN","GMRCEDT1",99,0)
 ..Q
"RTN","GMRCEDT1",100,0)
 .Q
"RTN","GMRCEDT1",101,0)
 S ^TMP("GMRCR",$J,"ED",GMRCLNO,0)=""
"RTN","GMRCEDT1",102,0)
 K FLG
"RTN","GMRCEDT1",103,0)
 Q
"RTN","GMRCEDT1",104,0)
RVRS(LINE,EDITED) ;reverse video for fields that can be edited
"RTN","GMRCEDT1",105,0)
 I '$G(EDITED) D CNTRL^VALM10(LINE,1,1,IORVON,IORVOFF) Q
"RTN","GMRCEDT1",106,0)
 D CNTRL^VALM10(LINE,1,1,IORVON_IOINHI,IORVOFF_IOINORM)
"RTN","GMRCEDT1",107,0)
 Q
"RTN","GMRCEDT2")
0^16^B18295173
"RTN","GMRCEDT2",1,0)
GMRCEDT2 ;SLC/JFR,DCM - RESUBMIT A CANCELLED CONSULT ;04/23/09  12:09
"RTN","GMRCEDT2",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,66**;DEC 27, 1997;Build 30
"RTN","GMRCEDT2",3,0)
 ;
"RTN","GMRCEDT2",4,0)
 ;ICRs in use: #2053 (DIE), #2056 (GET1^DIQ), #872 (ORD(101))
"RTN","GMRCEDT2",5,0)
 ;
"RTN","GMRCEDT2",6,0)
EN(GMRCO,COMNO) ;entry point into the routine
"RTN","GMRCEDT2",7,0)
 ;COMNO=CMDA from ^GMRCEDT2=comments array IEN from ^GMR(123,IEN,40,
"RTN","GMRCEDT2",8,0)
 ;GMRCO=IEN of the consult from file 123
"RTN","GMRCEDT2",9,0)
 I $S($P(^GMR(123,GMRCO,0),"^",12)'=13:1,$D(GMRCRSUB):1,1:0) D  Q
"RTN","GMRCEDT2",10,0)
 .S GMRCMSG="***     Consult Has Already Been Resubmitted   ***"
"RTN","GMRCEDT2",11,0)
 .S GMRCMSG(1)="***  No Further Action Is Required Or Allowed ***"
"RTN","GMRCEDT2",12,0)
 .D EXAC^GMRCADC(.GMRCMSG)
"RTN","GMRCEDT2",13,0)
 .S:'$D(GMRCRSUB) GMRCRSUB=1
"RTN","GMRCEDT2",14,0)
 .Q
"RTN","GMRCEDT2",15,0)
 N MSG S MSG=$$EDRESOK(GMRCO)
"RTN","GMRCEDT2",16,0)
 I '+MSG D EXAC^GMRCADC($P(MSG,U,2)) Q
"RTN","GMRCEDT2",17,0)
 I '$$PDOK^GMRCEDT4(GMRCO) D  Q
"RTN","GMRCEDT2",18,0)
 . D EXAC^GMRCADC("Can't resubmit!")
"RTN","GMRCEDT2",19,0)
 . S GMRCRSUB=1
"RTN","GMRCEDT2",20,0)
 . Q
"RTN","GMRCEDT2",21,0)
 I '$D(GMRCGUIF) W !,"Resubmitting Consult ... One moment please ..."
"RTN","GMRCEDT2",22,0)
 K ^TMP("GMRCSUB",$J) S ^TMP("GMRCSUB",$J)=0
"RTN","GMRCEDT2",23,0)
 I $D(GMRCEDT(1)) S ^TMP("GMRCSUB",$J,1)="GMRCSS^"_+GMRCEDT(1)
"RTN","GMRCEDT2",24,0)
 I $D(GMRCED(1)) D
"RTN","GMRCEDT2",25,0)
 . I $P(GMRCED(1),U)=$P(^GMR(123,+GMRCO,0),U,8) K GMRCED(1) Q
"RTN","GMRCEDT2",26,0)
 . S ^TMP("GMRCSUB",$J,2)="GMRCPROC^"_+GMRCED(1)_";GMR(123.3,"
"RTN","GMRCEDT2",27,0)
 I $D(GMRCED(2)) D
"RTN","GMRCEDT2",28,0)
 . I $P(GMRCED(2),U)=$P(^GMR(123,+GMRCO,0),U,18) K GMRCED(2) Q
"RTN","GMRCEDT2",29,0)
 . S ^TMP("GMRCSUB",$J,3)="GMRCION^"_$P(GMRCED(2),U)
"RTN","GMRCEDT2",30,0)
 I $D(GMRCED(3)) D
"RTN","GMRCEDT2",31,0)
 . I $P(GMRCED(3),U)=$P(^GMR(123,+GMRCO,0),U,9) K GMRCED(3) Q
"RTN","GMRCEDT2",32,0)
 . S ^TMP("GMRCSUB",$J,4)="GMRCURG^"_$P(GMRCED(3),U)
"RTN","GMRCEDT2",33,0)
 I $D(GMRCED(4)) D
"RTN","GMRCEDT2",34,0)
 . I $P(GMRCED(4),U)=$P(^GMR(123,+GMRCO,0),U,10) K GMRCED(4) Q
"RTN","GMRCEDT2",35,0)
 . S ^TMP("GMRCSUB",$J,5)="GMRCPL^"_$P(GMRCED(4),U)
"RTN","GMRCEDT2",36,0)
 I $D(GMRCED(5)) D  ;wat/66 add early date
"RTN","GMRCEDT2",37,0)
 . I $P(GMRCED(5),U)=$P(^GMR(123,+GMRCO,0),U,24) K GMRCED(5) Q
"RTN","GMRCEDT2",38,0)
 . S ^TMP("GMRCSUB",$J,6)="GMRCERDT^"_$P(GMRCED(5),U)
"RTN","GMRCEDT2",39,0)
 I $D(GMRCED(6)) D
"RTN","GMRCEDT2",40,0)
 . I $P(GMRCED(6),U)=$P(^GMR(123,+GMRCO,0),U,11) K GMRCED(6) Q
"RTN","GMRCEDT2",41,0)
 . I '$L($P(GMRCED(6),U)) S $P(GMRCED(6),U)="@"
"RTN","GMRCEDT2",42,0)
 . S ^TMP("GMRCSUB",$J,7)="GMRCATN^"_$P(GMRCED(6),U)
"RTN","GMRCEDT2",43,0)
 I $D(GMRCED(7)) D
"RTN","GMRCEDT2",44,0)
 . I GMRCED(7)=$G(^GMR(123,+GMRCO,30)) K GMRCED(7) Q
"RTN","GMRCEDT2",45,0)
 . I $P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"=$G(^GMR(123,GMRCO,30)) K GMRCED(7) Q
"RTN","GMRCEDT2",46,0)
 . I '$L($P(GMRCED(7),U)) S $P(GMRCED(7),U,1,2)="@"
"RTN","GMRCEDT2",47,0)
 . I $L($P(GMRCED(7),U,2)),$P(GMRCED(7),U,2)'="@" D
"RTN","GMRCEDT2",48,0)
 .. S $P(GMRCED(7),U)=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"
"RTN","GMRCEDT2",49,0)
 . S ^TMP("GMRCSUB",$J,8)="GMRCDIAG^"_GMRCED(7)
"RTN","GMRCEDT2",50,0)
 I $D(^TMP("GMRCED",$J,20)) S ^TMP("GMRCSUB",$J,20)="GMRCRFQ^" D
"RTN","GMRCEDT2",51,0)
 . N ND S ND=0
"RTN","GMRCEDT2",52,0)
 . F  S ND=$O(^TMP("GMRCED",$J,20,ND)) Q:'ND  D
"RTN","GMRCEDT2",53,0)
 .. S ^TMP("GMRCSUB",$J,20,ND)=^TMP("GMRCED",$J,20,ND,0)
"RTN","GMRCEDT2",54,0)
 I $D(^TMP("GMRCED",$J,40)) S ^TMP("GMRCSUB",$J,40)="COMMENT^" D
"RTN","GMRCEDT2",55,0)
 . N ND S ND=0
"RTN","GMRCEDT2",56,0)
 . F  S ND=$O(^TMP("GMRCED",$J,40,ND)) Q:'ND  D
"RTN","GMRCEDT2",57,0)
 .. S ^TMP("GMRCSUB",$J,40,ND)=^TMP("GMRCED",$J,40,ND,0)
"RTN","GMRCEDT2",58,0)
 D FILE^GMRCGUIC(+GMRCO,$NAME(^TMP("GMRCSUB",$J)),1)
"RTN","GMRCEDT2",59,0)
 N GMRCADUZ S GMRCADUZ=""
"RTN","GMRCEDT2",60,0)
 S DFN=$P(^GMR(123,+GMRCO,0),"^",2),GMRCPROV=$P(^(0),"^",14)
"RTN","GMRCEDT2",61,0)
 S GMRCTYPE=$P(^GMR(123,+GMRCO,0),U,17),GMRCTRLC="XX",VISIT="",RMBED=""
"RTN","GMRCEDT2",62,0)
 S DIE="^GMR(123,",DA=+GMRCO,DR="8////^S X=5;9////^S X=11" D ^DIE
"RTN","GMRCEDT2",63,0)
 K DIE,DA,DR
"RTN","GMRCEDT2",64,0)
 S GMRCRSUB=1
"RTN","GMRCEDT2",65,0)
 S GMRCURG=$P(^GMR(123,+GMRCO,0),"^",9)
"RTN","GMRCEDT2",66,0)
 I +$P(^GMR(123,+GMRCO,0),"^",11) S GMRCADUZ($P(^(0),"^",11))=""
"RTN","GMRCEDT2",67,0)
 S GMRCSVC=$P(^GMR(123,+GMRCO,0),"^",5)
"RTN","GMRCEDT2",68,0)
 I +GMRCSVC D
"RTN","GMRCEDT2",69,0)
 . D EN^GMRCT(GMRCSVC)
"RTN","GMRCEDT2",70,0)
 S GMRCORTX="Resubmitted consult "_$$ORTX^GMRCAU(+GMRCO)_$S(+GMRCURG:" ("_$P(^ORD(101,+GMRCURG,0),"^",2)_")",1:"")
"RTN","GMRCEDT2",71,0)
 K GMRCFL,GMRCPROV,GMRCTYPE,GMRCTRLC,VISIT,RMBED,GMRCOM,GMRCURG
"RTN","GMRCEDT2",72,0)
 K GMRCSVC,GMRCORTX
"RTN","GMRCEDT2",73,0)
 Q
"RTN","GMRCEDT2",74,0)
EDRESOK(GMRCDA) ;check cslt or proc to see if still resubmittable
"RTN","GMRCEDT2",75,0)
 ; if procedure is inactive or no services, not resubmittable
"RTN","GMRCEDT2",76,0)
 ; if service is grouper or disabled, not resubmittable
"RTN","GMRCEDT2",77,0)
 N MSG,GMRC
"RTN","GMRCEDT2",78,0)
 Q:'$D(^GMR(123,+$G(GMRCDA),0)) "0^Invalid Consult Number"
"RTN","GMRCEDT2",79,0)
 I $P($G(^GMR(123,+GMRCDA,12)),U,5)="F" D  Q MSG
"RTN","GMRCEDT2",80,0)
 . S MSG="0^This inter-facility cconsult may only be resubmitted by the"
"RTN","GMRCEDT2",81,0)
 . S MSG=MSG_" ordering facility."
"RTN","GMRCEDT2",82,0)
 S GMRC(0)=^GMR(123,+GMRCDA,0)
"RTN","GMRCEDT2",83,0)
 I '$P(GMRC(0),U,8) D  Q MSG
"RTN","GMRCEDT2",84,0)
 . I "19"[+$P(^GMR(123.5,+$P(GMRC(0),U,5),0),U,2) D  Q
"RTN","GMRCEDT2",85,0)
 .. S MSG="0^The service for this Consult is no longer orderable."
"RTN","GMRCEDT2",86,0)
 . S MSG=1
"RTN","GMRCEDT2",87,0)
 S MSG=1
"RTN","GMRCEDT2",88,0)
 I "19"[+$P(^GMR(123.5,+$P(GMRC(0),U,5),0),U,2) S MSG=0
"RTN","GMRCEDT2",89,0)
 I '$L($$GET1^DIQ(123.3,+$P(GMRC(0),U,8),.01)) S MSG=0
"RTN","GMRCEDT2",90,0)
 I +$$GET1^DIQ(123.3,+$P(GMRC(0),U,8),.02) S MSG=0
"RTN","GMRCEDT2",91,0)
 I '$D(^GMR(123.3,+$P(GMRC(0),U,8),2,"B",+$P(GMRC(0),U,5))) S MSG=0
"RTN","GMRCEDT2",92,0)
 I MSG=0 D
"RTN","GMRCEDT2",93,0)
 . S MSG=MSG_"^This procedure may no longer be ordered or the service "
"RTN","GMRCEDT2",94,0)
 . S MSG=MSG_"may no longer perform it."
"RTN","GMRCEDT2",95,0)
 Q MSG
"RTN","GMRCEDT3")
0^17^B17640061
"RTN","GMRCEDT3",1,0)
GMRCEDT3 ;SLC/DCM,JFR - file edit/resubmit ;04/23/09  12:19
"RTN","GMRCEDT3",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,15,22,66**;DEC 27, 1997;Build 30
"RTN","GMRCEDT3",3,0)
 ;
"RTN","GMRCEDT3",4,0)
 ;IRCS in use: #2053 (DIE), #2056 (GET1^DIQ), #10103 (XLFDT), #10104 (XLFSTR)
"RTN","GMRCEDT3",5,0)
 ;
"RTN","GMRCEDT3",6,0)
EN(GMRCDA) ;File tracking Data from array
"RTN","GMRCEDT3",7,0)
 W:'$D(GMRCGUIF) !,"Filing Tracking Data..."
"RTN","GMRCEDT3",8,0)
 N GMRCOUNT,GMRC40DA
"RTN","GMRCEDT3",9,0)
 S GMRCDT=$$NOW^XLFDT
"RTN","GMRCEDT3",10,0)
 S DIE="^GMR(123,",DA=GMRCDA,DR="8////^S X=5" D ^DIE K DIE,DA,DR
"RTN","GMRCEDT3",11,0)
 I '$D(^GMR(123,GMRCDA,40,0)) S ^GMR(123,GMRCDA,40,0)="123.02^^"
"RTN","GMRCEDT3",12,0)
 S DA=$S(+$P(^GMR(123,GMRCDA,40,0),"^",3):$P(^(0),"^",3)+1,1:1)
"RTN","GMRCEDT3",13,0)
 S GMRC40DA=DA
"RTN","GMRCEDT3",14,0)
 S $P(^GMR(123,GMRCDA,40,0),"^",3,4)=DA_"^"_DA D
"RTN","GMRCEDT3",15,0)
 .S ^GMR(123,GMRCDA,40,DA,0)=GMRCDT_"^"_$O(^GMR(123.1,"B","EDIT/RESUBMITTED",0))_"^"_GMRCDT_"^"_DUZ_"^"_DUZ D
"RTN","GMRCEDT3",16,0)
 .S ^GMR(123,GMRCDA,40,DA,1,0)="^^^^"_GMRCDT_"^" D
"RTN","GMRCEDT3",17,0)
 ..S GMRCOUNT=1,GMRCND=0,^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)=$$REPEAT^XLFSTR("-",21)_" PREVIOUS VALUES OF EDITED FIELDS  "_$$REPEAT^XLFSTR("-",21),GMRCOUNT=GMRCOUNT+1
"RTN","GMRCEDT3",18,0)
 ..I '$D(GMRCFLD) S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="No Fields Were Edited Before Resubmission",GMRCOUNT=GMRCOUNT+1 Q
"RTN","GMRCEDT3",19,0)
 ..F  S GMRCND=$O(GMRCFLD(GMRCND)) Q:GMRCND=""  D  S GMRCOUNT=GMRCOUNT+1
"RTN","GMRCEDT3",20,0)
 ...I GMRCND=.1 S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="DISPLAY TEXT OF ITEM ORDERED: "_$P(GMRCFLD(GMRCND),"^",1),GMRCOUNT=GMRCOUNT+1 Q
"RTN","GMRCEDT3",21,0)
 ...I GMRCND=1 D  S GMRCOUNT=GMRCOUNT+1 Q
"RTN","GMRCEDT3",22,0)
 ....S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="To Service: "_$S($L($P(GMRCFLD(GMRCND),U)):$P(GMRCFLD(GMRCND),U),1:"No Previous Value")
"RTN","GMRCEDT3",23,0)
 ....Q
"RTN","GMRCEDT3",24,0)
 ...I GMRCND=4 S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="Procedure: "_$$GET1^DIQ(123.3,+GMRCFLD(4),.01) Q
"RTN","GMRCEDT3",25,0)
 ...I GMRCND=14 S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="Performed as Inpt or Outpt: "_$S($L($P(GMRCFLD(GMRCND),"^")):$P(GMRCFLD(GMRCND),U),1:"No Previous Value") Q
"RTN","GMRCEDT3",26,0)
 ...I $S(GMRCND=5:1,GMRCND=6:1,GMRCND=13:1,1:0) D  Q
"RTN","GMRCEDT3",27,0)
 ....N CAPTION S CAPTION=$S(GMRCND=5:"Urgency: ",GMRCND=6:"Place of Consultation: ",1:"Type of Request: ")
"RTN","GMRCEDT3",28,0)
 ....S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)=CAPTION_$S($L($P(GMRCFLD(GMRCND),U)):$P(GMRCFLD(GMRCND),U),1:"No Previous Value")
"RTN","GMRCEDT3",29,0)
 ...I GMRCND=7 S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="Attention: "_$S($L($P(GMRCFLD(GMRCND),U)):$P(GMRCFLD(GMRCND),U),1:"No Previous Value") Q
"RTN","GMRCEDT3",30,0)
 ...I GMRCND=17 S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="Earliest Appropriate Date: "_$S($L($P(GMRCFLD(GMRCND),U)):$P(GMRCFLD(GMRCND),U),1:"No Previous Value") ;wat/66
"RTN","GMRCEDT3",31,0)
 ...I GMRCND=20 N GMRCND1 S GMRCND1=0,GMRCOUNT=GMRCOUNT+1 D  Q
"RTN","GMRCEDT3",32,0)
 ....S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="Reason for Request: "
"RTN","GMRCEDT3",33,0)
 ....S GMRCOUNT=GMRCOUNT+1
"RTN","GMRCEDT3",34,0)
 ....F  S GMRCND1=$O(@GMRCFLD(20)@(GMRCND1)) Q:GMRCND1=""  S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)=@GMRCFLD(20)@(GMRCND1,0),GMRCOUNT=GMRCOUNT+1
"RTN","GMRCEDT3",35,0)
 ...I GMRCND=30 S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)="Provisional Diagnosis: "_$S($L($P(GMRCFLD(GMRCND),U)):$P(GMRCFLD(GMRCND),U),1:"No Previous Value") Q
"RTN","GMRCEDT3",36,0)
 ...I GMRCND=40 S ^GMR(123,+GMRCDA,40,DA,1,GMRCOUNT,0)=$P(GMRCFLD(GMRCND),"^",1) Q
"RTN","GMRCEDT3",37,0)
 ...Q
"RTN","GMRCEDT3",38,0)
 ..Q
"RTN","GMRCEDT3",39,0)
 .S ^GMR(123,GMRCDA,40,DA,1,GMRCOUNT,0)=$$REPEAT^XLFSTR("-",75),GMRCOUNT=GMRCOUNT-1,^GMR(123,+GMRCDA,40,"B",GMRCDT,DA)=""
"RTN","GMRCEDT3",40,0)
 .S $P(^GMR(123,GMRCDA,40,DA,1,0),"^",3)=GMRCOUNT-1,$P(^(0),"^",4)=GMRCOUNT-1,^GMR(123,+GMRCDA,40,"B",GMRCDT,DA)=""
"RTN","GMRCEDT3",41,0)
 .Q
"RTN","GMRCEDT3",42,0)
 K GMRCIND,GMRCND
"RTN","GMRCEDT3",43,0)
 Q GMRC40DA
"RTN","GMRCEDT3",44,0)
 ;
"RTN","GMRCEDT3",45,0)
ADDCM(GMRCO) ;set up to add comment when none exists or to add a new comment
"RTN","GMRCEDT3",46,0)
 ;returns DA for the entry it sets up
"RTN","GMRCEDT3",47,0)
 N X
"RTN","GMRCEDT3",48,0)
 S:'$D(^GMR(123,+GMRCO,40,0)) ^(0)="^123.02DA^^" S X=$S($P(^GMR(123,GMRCO,40,0),"^",3):$P(^(0),"^",3)+1,1:1)
"RTN","GMRCEDT3",49,0)
 S $P(^GMR(123,GMRCO,40,0),"^",3,4)=X_"^"_X
"RTN","GMRCEDT3",50,0)
 Q X
"RTN","GMRCEDT3",51,0)
 ;
"RTN","GMRCEDT3",52,0)
AUDIT0(DA,GMRCDA) ;Add the necessary tracking information to word processing fields
"RTN","GMRCEDT3",53,0)
 N DIE,DR
"RTN","GMRCEDT3",54,0)
 S DIE="^GMR(123,"_GMRCDA_",40,",DA(1)=GMRCDA,DR=".01////^S X=$$NOW^XLFDT;1////^S X=GMRCA;2////^S X=$$NOW^XLFDT;3////^S X=DUZ;4////^S X=DUZ"
"RTN","GMRCEDT3",55,0)
 D ^DIE
"RTN","GMRCEDT3",56,0)
 Q
"RTN","GMRCEDT4")
0^18^B81417633
"RTN","GMRCEDT4",1,0)
GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ;04/23/09  12:48
"RTN","GMRCEDT4",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,66**;DEC 27, 1997;Build 30
"RTN","GMRCEDT4",3,0)
 ;
"RTN","GMRCEDT4",4,0)
 ; This routine invokes IA #3991 (ICDAPIU), #872 (ORD(101)), #10142 (DDIOL), #10006 (DIC)
"RTN","GMRCEDT4",5,0)
 ;                         #2051 (FIND1^DIC), #2056 (GET1^DIQ), #10026 (DIR), #10028 (DIWE)
"RTN","GMRCEDT4",6,0)
 ;                         #1609 (CONFIG^LEXSET), #10103 (XLFDT), #10104 (XLFSTR), #10140 (XQORM)
"RTN","GMRCEDT4",7,0)
 ;
"RTN","GMRCEDT4",8,0)
 Q
"RTN","GMRCEDT4",9,0)
EDITFLD(GMRCO)    ;edit field in file 123.
"RTN","GMRCEDT4",10,0)
 ;GMRCO=IEN of consult record in file 123
"RTN","GMRCEDT4",11,0)
 N DIR,X,Y,GMRCSS,GMRCPROC,GMRCPROC,GMRCURG,GMRCPL,GMRCREND,GMRCY,GMRCX
"RTN","GMRCEDT4",12,0)
 N GMRCMSG,GMRCTAG
"RTN","GMRCEDT4",13,0)
 I $S($P(^GMR(123,GMRCO,0),"^",12)'=13:1,$D(GMRCRSUB):1,1:0) D  Q
"RTN","GMRCEDT4",14,0)
 .S GMRCMSG="This consult is no longer editable." D EXAC^GMRCADC(GMRCMSG)
"RTN","GMRCEDT4",15,0)
 S GMRCMSG=$$EDRESOK^GMRCEDT2(GMRCO)
"RTN","GMRCEDT4",16,0)
 I '+GMRCMSG D EXAC^GMRCADC($P(GMRCMSG,U,2)) Q
"RTN","GMRCEDT4",17,0)
 I $$PDOK(GMRCO)
"RTN","GMRCEDT4",18,0)
 S DIR(0)="LAO^1:9",DIR("A")="Select the fields to edit: "
"RTN","GMRCEDT4",19,0)
 D ^DIR I $D(DIRUT) Q
"RTN","GMRCEDT4",20,0)
 I $P(Y,",")<1 Q
"RTN","GMRCEDT4",21,0)
 S GMRCY=Y
"RTN","GMRCEDT4",22,0)
 F GMRCX=1:1:9 S GMRCTAG=$P(GMRCY,",",GMRCX) Q:'GMRCTAG  D
"RTN","GMRCEDT4",23,0)
 . D SETUP
"RTN","GMRCEDT4",24,0)
 . D @GMRCTAG
"RTN","GMRCEDT4",25,0)
 . K DIROUT,DIRUT,DTOUT,DUOUT
"RTN","GMRCEDT4",26,0)
 . D EN^GMRCEDT1(+GMRCO),INIT^GMRCEDIT
"RTN","GMRCEDT4",27,0)
 Q
"RTN","GMRCEDT4",28,0)
SETUP   ;get info needed for edit (save global reads)
"RTN","GMRCEDT4",29,0)
 S:$D(GMRCEDT(1)) GMRCSS=GMRCEDT(1)
"RTN","GMRCEDT4",30,0)
 I '$D(GMRCSS) S GMRCSS=$P(^GMR(123,+GMRCO,0),U,5),GMRCSS=GMRCSS_U_$P(^GMR(123.5,GMRCSS,0),U)
"RTN","GMRCEDT4",31,0)
 S:$D(GMRCED(1)) GMRCPROC=GMRCED(1)
"RTN","GMRCEDT4",32,0)
 I '$D(GMRCPROC) S GMRCPROC=+$P(^GMR(123,+GMRCO,0),U,8),GMRCPROC=GMRCPROC_U_$$GET1^DIQ(123.3,+GMRCPROC,.01)
"RTN","GMRCEDT4",33,0)
 S:$D(GMRCED(2)) GMRCREND=GMRCED(2)
"RTN","GMRCEDT4",34,0)
 I '$D(GMRCREND) S GMRCREND=$P(^GMR(123,GMRCO,0),U,18),GMRCREND=GMRCREND_U_$S(GMRCREND="I":"In",1:"Out")_"patient"
"RTN","GMRCEDT4",35,0)
 S:$D(GMRCED(3)) GMRCURG=GMRCED(3)
"RTN","GMRCEDT4",36,0)
 I '$D(GMRCURG) S GMRCURG=$P(^GMR(123,+GMRCO,0),U,9),GMRCURG=GMRCURG_U_$$GET1^DIQ(101,+GMRCURG,1)
"RTN","GMRCEDT4",37,0)
 S:$D(GMRCED(4)) GMRCPL=GMRCED(4)
"RTN","GMRCEDT4",38,0)
 I '$D(GMRCPL) S GMRCPL=$P(^GMR(123,+GMRCO,0),U,10),GMRCPL=GMRCPL_U_$$GET1^DIQ(101,+GMRCPL,1)
"RTN","GMRCEDT4",39,0)
 Q
"RTN","GMRCEDT4",40,0)
01       ;edit TO SERVICE
"RTN","GMRCEDT4",41,0)
 N I,PROCSERV,DIR,X,Y
"RTN","GMRCEDT4",42,0)
 I $G(GMRCPROC) D  Q:'PROCSERV
"RTN","GMRCEDT4",43,0)
 . N I S I=0,PROCSERV=0 F  S I=$O(^GMR(123.3,+GMRCPROC,2,"B",I)) Q:'I  D
"RTN","GMRCEDT4",44,0)
 .. S PROCSERV(I)="",PROCSERV=PROCSERV+1
"RTN","GMRCEDT4",45,0)
 . I PROCSERV=1 W !,"Only one SERVICE can perform this procedure.",!
"RTN","GMRCEDT4",46,0)
 S DIR(0)="PA^123.5:EMQ"
"RTN","GMRCEDT4",47,0)
 I $G(PROCSERV) D
"RTN","GMRCEDT4",48,0)
 . I $D(PROCSERV(+GMRCSS)) Q
"RTN","GMRCEDT4",49,0)
 . S DIR("B")=$$GET1^DIQ(123.5,$O(PROCSERV(0)),.01)
"RTN","GMRCEDT4",50,0)
 I '$D(DIR("B")) S DIR("B")=$P(GMRCSS,U,2)
"RTN","GMRCEDT4",51,0)
 S DIR("A")="Select the Service to perform this request: "
"RTN","GMRCEDT4",52,0)
 S DIR("S")="I $P(^(0),U,2)<1" ;naked reference for ^GMR(123.5
"RTN","GMRCEDT4",53,0)
 I +$G(GMRCPROC) S DIR("S")=DIR("S")_",$D(PROCSERV(+Y))"
"RTN","GMRCEDT4",54,0)
 S DIR("??")="^D LISTALL^GMRCASV"
"RTN","GMRCEDT4",55,0)
 D ^DIR I $D(DUOUT)!($D(DTOUT)) Q
"RTN","GMRCEDT4",56,0)
 I Y<1!(+Y=+GMRCSS) W !,$$NOCHG,! Q
"RTN","GMRCEDT4",57,0)
 S GMRCEDT(1)=Y,GMRCSS=Y
"RTN","GMRCEDT4",58,0)
 Q
"RTN","GMRCEDT4",59,0)
1 ;edit Procedure
"RTN","GMRCEDT4",60,0)
 W !,$C(7),"The procedure associated with a request may not be changed."
"RTN","GMRCEDT4",61,0)
 W !,"Place a new request if a different procedure is desired"
"RTN","GMRCEDT4",62,0)
 H 2
"RTN","GMRCEDT4",63,0)
 Q
"RTN","GMRCEDT4",64,0)
2       ;edit service rendered
"RTN","GMRCEDT4",65,0)
 N DIR,X,Y,GMRCURSV,GMRCPLSV,GMRCED4,GMRCED5,RENDED
"RTN","GMRCEDT4",66,0)
 S DIR(0)="S:A^I:Inpatient;O:Outpatient",DIR("B")=$P(GMRCREND,U,2)
"RTN","GMRCEDT4",67,0)
 S DIR("A")="Service to be performed Inpatient or Outpatient: "
"RTN","GMRCEDT4",68,0)
 D ^DIR I $D(DUOUT)!($D(DTOUT)) W !,$$NOCHG,! Q
"RTN","GMRCEDT4",69,0)
 I Y'=$P(GMRCREND,U) S RENDED=Y_U_Y(0)
"RTN","GMRCEDT4",70,0)
 I '$D(RENDED) Q
"RTN","GMRCEDT4",71,0)
 I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D  I '$D(RENDED) Q
"RTN","GMRCEDT4",72,0)
 . N GMRCREND,CHGIO S GMRCREND=RENDED
"RTN","GMRCEDT4",73,0)
 . W $C(7),!!,"The urgency of this request is no longer valid.",!
"RTN","GMRCEDT4",74,0)
 . S GMRCURSV=GMRCURG S:$D(GMRCED(3)) GMRCED3=GMRCED(3)
"RTN","GMRCEDT4",75,0)
 . S CHGREND="" D 3
"RTN","GMRCEDT4",76,0)
 . I '$$VALIDUR(GMRCURG,RENDED,+$G(GMRCPROC)) D  Q
"RTN","GMRCEDT4",77,0)
 .. W !,$C(7),"Unable to change the way service is rendered.",!
"RTN","GMRCEDT4",78,0)
 .. K RENDED S GMRCURG=GMRCURSV S:$D(GMRCED3) GMRCED(3)=GMRCED3
"RTN","GMRCEDT4",79,0)
 I '$$VALIDPL(GMRCPL,RENDED) D  I '$D(RENDED) Q
"RTN","GMRCEDT4",80,0)
 . N GMRCREND,CHGREND S GMRCREND=RENDED
"RTN","GMRCEDT4",81,0)
 . W $C(7),!!,"The Place of Consultation is no longer valid.",!
"RTN","GMRCEDT4",82,0)
 . S GMRCPLSV=GMRCPL S:$D(GMRCED(4)) GMRCED4=GMRCED(4) S CHGREND="" D 4
"RTN","GMRCEDT4",83,0)
 . I '$$VALIDPL(GMRCPL,RENDED) D  Q
"RTN","GMRCEDT4",84,0)
 .. W !,$C(7),"Unable to change the way service is rendered.",!
"RTN","GMRCEDT4",85,0)
 .. K RENDED S GMRCPL=GMRCPLSV S:$D(GMRCED4) GMRCED(4)=GMRCED4
"RTN","GMRCEDT4",86,0)
 .. S:$D(GMRCURSV) GMRCURG=GMRCURSV
"RTN","GMRCEDT4",87,0)
 .. S:$D(GMRCED3) GMRCED(3)=GMRCED3
"RTN","GMRCEDT4",88,0)
 S (GMRCREND,GMRCED(2))=RENDED
"RTN","GMRCEDT4",89,0)
 Q
"RTN","GMRCEDT4",90,0)
3 ;edit urgency
"RTN","GMRCEDT4",91,0)
 N X,Y,XQORM
"RTN","GMRCEDT4",92,0)
 I $P(GMRCREND,U)="O" S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM - OUTPATIENT")
"RTN","GMRCEDT4",93,0)
 I '$D(Y) D  ;inpatient
"RTN","GMRCEDT4",94,0)
 .I '$G(GMRCPROC) S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM CSLT - INPATIENT") Q
"RTN","GMRCEDT4",95,0)
 .S Y=$$FIND1^DIC(101,"","QX","GMRCURGENCYM REQ - INPATIENT")
"RTN","GMRCEDT4",96,0)
 I 'Y W !,$C(7),"Unable to change urgency." Q
"RTN","GMRCEDT4",97,0)
 S XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Urgency: "
"RTN","GMRCEDT4",98,0)
 S XQORM("^^NO")=0
"RTN","GMRCEDT4",99,0)
 S:'$D(CHGREND) XQORM("B")=$P($G(GMRCURG),U,2)
"RTN","GMRCEDT4",100,0)
 D EN^XQORM
"RTN","GMRCEDT4",101,0)
 Q:Y'>0
"RTN","GMRCEDT4",102,0)
 I $P(Y(1),U,2)'=+GMRCURG D
"RTN","GMRCEDT4",103,0)
 . S GMRCED(3)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCURG=GMRCED(3)
"RTN","GMRCEDT4",104,0)
 Q
"RTN","GMRCEDT4",105,0)
4 ;edit place of CSLT
"RTN","GMRCEDT4",106,0)
 N X,Y,XQORM
"RTN","GMRCEDT4",107,0)
 S Y=$$FIND1^DIC(101,,"QX","GMRCPLACEM - "_$$UP^XLFSTR($P(GMRCREND,U,2))) Q:'Y
"RTN","GMRCEDT4",108,0)
 S XQORM=Y_";ORD(101,"
"RTN","GMRCEDT4",109,0)
 S XQORM(0)="1AR\",XQORM("A")="Place of Consultation: ",XQORM("NO^^")=""
"RTN","GMRCEDT4",110,0)
 S:'$D(CHGREND) XQORM("B")=$P($G(GMRCPL),U,2)
"RTN","GMRCEDT4",111,0)
 D EN^XQORM
"RTN","GMRCEDT4",112,0)
 Q:Y'>0
"RTN","GMRCEDT4",113,0)
 I $P(Y(1),U,2)'=+GMRCPL D
"RTN","GMRCEDT4",114,0)
 . S GMRCED(4)=$P(Y(1),U,2)_U_$P(Y(1),U,3),GMRCPL=GMRCED(4)
"RTN","GMRCEDT4",115,0)
 Q
"RTN","GMRCEDT4",116,0)
5 ;edit Earliest Appr. Date wat/66
"RTN","GMRCEDT4",117,0)
 N X,Y,DIR
"RTN","GMRCEDT4",118,0)
 S DIR(0)="D^^K:Y<DT X",DIR("A")="Earliest Appropriate Date: " ;S DIR(0)="D^DT:GMRCFTDT:EX"
"RTN","GMRCEDT4",119,0)
 S DIR("?")="Enter a date greater than or equal to TODAY"
"RTN","GMRCEDT4",120,0)
 S DIR("B")=$$FMTE^XLFDT(DT)
"RTN","GMRCEDT4",121,0)
 D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
"RTN","GMRCEDT4",122,0)
 S GMRCED(5)=Y_U_Y(0)
"RTN","GMRCEDT4",123,0)
 Q
"RTN","GMRCEDT4",124,0)
6 ;edit ATTN person
"RTN","GMRCEDT4",125,0)
 N X,Y,DIR
"RTN","GMRCEDT4",126,0)
 S DIR(0)="PAO^200:EQM",DIR("A")="Select ATTENTION person: "
"RTN","GMRCEDT4",127,0)
 S DIR("B")=$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),U,11),.01)
"RTN","GMRCEDT4",128,0)
 S:$D(GMRCED(6)) DIR("B")=$P($G(GMRCED(6)),U,2)
"RTN","GMRCEDT4",129,0)
 K:'$L(DIR("B")) DIR("B")
"RTN","GMRCEDT4",130,0)
 D ^DIR I $D(DTOUT)!($D(DUOUT)) Q
"RTN","GMRCEDT4",131,0)
 I $G(DIR("B"))=$P(Y,U,2) Q
"RTN","GMRCEDT4",132,0)
 S GMRCED(6)=$S(Y=-1:"",1:Y)
"RTN","GMRCEDT4",133,0)
 I GMRCED(6)="" W !,?5,"<DELETED>",!
"RTN","GMRCEDT4",134,0)
 Q
"RTN","GMRCEDT4",135,0)
7 ;edit prov. DX
"RTN","GMRCEDT4",136,0)
 N X,Y,DIC,DIR,PRMPT
"RTN","GMRCEDT4",137,0)
 S PRMPT=$$PROVDX^GMRCUTL1(+$P(^GMR(123,+GMRCO,0),U,5))
"RTN","GMRCEDT4",138,0)
 I $P(PRMPT,U,2)="F" D
"RTN","GMRCEDT4",139,0)
 . S DIR(0)="FA^2:180",DIR("A")="Provisional Diagnosis: "
"RTN","GMRCEDT4",140,0)
 . I $P(PRMPT,U)'="R" S $P(DIR(0),U)="FAO"
"RTN","GMRCEDT4",141,0)
 . S:$D(GMRCED(7)) DIR("B")=$P(GMRCED(7),U)
"RTN","GMRCEDT4",142,0)
 . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,+GMRCO,30))
"RTN","GMRCEDT4",143,0)
 . K:'$L(DIR("B")) DIR("B")
"RTN","GMRCEDT4",144,0)
 . D ^DIR Q:$D(DTOUT)!($D(DUOUT))  Q:Y=$G(DIR("B"))
"RTN","GMRCEDT4",145,0)
 . I '$L(Y) W !,?5,"<DELETED>",!
"RTN","GMRCEDT4",146,0)
 . S GMRCED(7)=Y
"RTN","GMRCEDT4",147,0)
 I $P(PRMPT,U,2)="L" D
"RTN","GMRCEDT4",148,0)
 . N DIR,X,Y,DTOUT,DUOUT,VAL
"RTN","GMRCEDT4",149,0)
 . I $D(GMRCED(7)) D
"RTN","GMRCEDT4",150,0)
 .. I '$L($P(GMRCED(7),U,2)) S DIR("B")=$P(GMRCED(7),U) Q
"RTN","GMRCEDT4",151,0)
 .. S DIR("B")=$P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"
"RTN","GMRCEDT4",152,0)
 . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,GMRCO,30))
"RTN","GMRCEDT4",153,0)
 . K:'$L(DIR("B")) DIR("B")
"RTN","GMRCEDT4",154,0)
 . S DIR("?")="Enter a code or term for the provisional diagnosis."
"RTN","GMRCEDT4",155,0)
 . S DIR("A")="Provisional Diagnosis: "
"RTN","GMRCEDT4",156,0)
 . S DIR(0)="FA"_$S($P(PRMPT,U)'="R":"O",1:"")_"^1:180"
"RTN","GMRCEDT4",157,0)
 . D ^DIR
"RTN","GMRCEDT4",158,0)
 . I $D(DTOUT)!($D(DUOUT)) Q
"RTN","GMRCEDT4",159,0)
 . I '$L(Y) W !,?5,"<DELETED>",! S GMRCED(7)="" Q
"RTN","GMRCEDT4",160,0)
 . I Y=$G(DIR("B")) Q
"RTN","GMRCEDT4",161,0)
 . I $E(Y,1)=" " W !,"Leading space not allowed, no change." Q
"RTN","GMRCEDT4",162,0)
 . S VAL=$$LEXLKUP(Y)
"RTN","GMRCEDT4",163,0)
 . I '$L(VAL),$P(PRMPT,U)="R" W !,"Prov. DX required. No change." Q
"RTN","GMRCEDT4",164,0)
 . I VAL=$G(^GMR(123,GMRCO,30)) W !,"No change." Q
"RTN","GMRCEDT4",165,0)
 . I ($P(VAL,U)_" ("_$P(VAL,U,2)_")")=$G(^GMR(123,GMRCO,30)) D  Q
"RTN","GMRCEDT4",166,0)
 .. W !,"No change."
"RTN","GMRCEDT4",167,0)
 . I '$L(VAL) W !,?5,"<DELETED>",!
"RTN","GMRCEDT4",168,0)
 . S GMRCED(7)=VAL
"RTN","GMRCEDT4",169,0)
 Q
"RTN","GMRCEDT4",170,0)
 ;
"RTN","GMRCEDT4",171,0)
LEXLKUP(GMRCX)  ; run input through the Lexicon
"RTN","GMRCEDT4",172,0)
 ;
"RTN","GMRCEDT4",173,0)
 N DIC,X,Y,DUOUT,DTOUT
"RTN","GMRCEDT4",174,0)
 D CONFIG^LEXSET("ICD","ICD",DT)
"RTN","GMRCEDT4",175,0)
 S DIC="^LEX(757.01,",DIC(0)="EQM",DIC("B")=GMRCX,X=GMRCX
"RTN","GMRCEDT4",176,0)
 D ^DIC
"RTN","GMRCEDT4",177,0)
 I $D(DTOUT)!($D(DUOUT))!($G(Y)<1) Q ""
"RTN","GMRCEDT4",178,0)
 Q $P(Y,U,2)_U_Y(1)
"RTN","GMRCEDT4",179,0)
 ;
"RTN","GMRCEDT4",180,0)
8 ;edit Reason for Request
"RTN","GMRCEDT4",181,0)
 N DIC,DIWESUB,DWLW,DWPK
"RTN","GMRCEDT4",182,0)
 I $D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCEDSV",$J,20)=^TMP("GMRCED",$J,20)
"RTN","GMRCEDT4",183,0)
 I '$D(^TMP("GMRCED",$J,20)) M ^TMP("GMRCED",$J,20)=^GMR(123,+GMRCO,20)
"RTN","GMRCEDT4",184,0)
 S DIC="^TMP(""GMRCED"",$J,20,",DIWESUB="Reason for Request"
"RTN","GMRCEDT4",185,0)
 W !,"Editing Reason for Request:",!
"RTN","GMRCEDT4",186,0)
 S DWPK=1,DWLW=74 D EN^DIWE
"RTN","GMRCEDT4",187,0)
 I '$$DIFFRFR($D(^TMP("GMRCEDSV",$J,20))) D  Q
"RTN","GMRCEDT4",188,0)
 . I $D(^TMP("GMRCEDSV",$J,20)) K ^TMP("GMRCEDSV",$J,20) Q
"RTN","GMRCEDT4",189,0)
 . K ^TMP("GMRCED",$J,20)
"RTN","GMRCEDT4",190,0)
 K ^TMP("GMRCEDSV",$J,20)
"RTN","GMRCEDT4",191,0)
 I '$D(^TMP("GMRCED",$J,20))!('$O(^TMP("GMRCED",$J,20,0))) D
"RTN","GMRCEDT4",192,0)
 . N GMRCMSG
"RTN","GMRCEDT4",193,0)
 . S GMRCMSG="Unable to delete Reason for Request (REQUIRED)"
"RTN","GMRCEDT4",194,0)
 . D EXAC^GMRCADC(GMRCMSG)
"RTN","GMRCEDT4",195,0)
 . K ^TMP("GMRCED",$J,20)
"RTN","GMRCEDT4",196,0)
 Q
"RTN","GMRCEDT4",197,0)
9 ;add comment
"RTN","GMRCEDT4",198,0)
 N DIC,DIWEPSE,DIWESUB,DWLW,DWPK
"RTN","GMRCEDT4",199,0)
 I $D(^TMP("GMRCED",$J,40)) D
"RTN","GMRCEDT4",200,0)
 . W !,"An unsaved comment exists. You may edit this comment.",!
"RTN","GMRCEDT4",201,0)
 . S DIWEPSE=1
"RTN","GMRCEDT4",202,0)
 S DIC="^TMP(""GMRCED"",$J,40,",DIWESUB="New Comment"
"RTN","GMRCEDT4",203,0)
 W !,"Adding new comment:",!
"RTN","GMRCEDT4",204,0)
 S DWPK=1,DWLW=74 D EN^DIWE
"RTN","GMRCEDT4",205,0)
 I '$O(^TMP("GMRCED",$J,40,0)) K ^TMP("GMRCED",$J,40)
"RTN","GMRCEDT4",206,0)
 Q
"RTN","GMRCEDT4",207,0)
DIFFRFR(SAVED) ;edited reason for req same as original?
"RTN","GMRCEDT4",208,0)
 N I,DIFF
"RTN","GMRCEDT4",209,0)
 I SAVED,$P($G(^TMP("GMRCED",$J,20,0)),U,3,4)'=$P($G(^TMP("GMRCEDSV",$J,20,0)),U,3,4) S DIFF=1 Q 1
"RTN","GMRCEDT4",210,0)
 I 'SAVED,$P($G(^TMP("GMRCED",$J,20,0)),U,3,4)'=$P($G(^GMR(123,+GMRCO,20,0)),U,3,4) S DIFF=1 Q 1
"RTN","GMRCEDT4",211,0)
 I SAVED S I=0 F  S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF))  D
"RTN","GMRCEDT4",212,0)
 . I ^TMP("GMRCED",$J,20,I,0)=$G(^TMP("GMRCEDSV",$J,20,I,0)) Q
"RTN","GMRCEDT4",213,0)
 . S DIFF=1
"RTN","GMRCEDT4",214,0)
 . Q
"RTN","GMRCEDT4",215,0)
 I 'SAVED S I=0 F  S I=$O(^TMP("GMRCED",$J,20,I)) Q:'I!($D(DIFF))  D
"RTN","GMRCEDT4",216,0)
 . I ^TMP("GMRCED",$J,20,I,0)'=$G(^GMR(123,+GMRCO,20,I,0)) S DIFF=1
"RTN","GMRCEDT4",217,0)
 . Q
"RTN","GMRCEDT4",218,0)
 Q $G(DIFF)
"RTN","GMRCEDT4",219,0)
VALIDPL(PL,REND) ; place still valid?
"RTN","GMRCEDT4",220,0)
 N PLMENU
"RTN","GMRCEDT4",221,0)
 S PLMENU=$S($P(REND,U)="I":"IN",1:"OUT")
"RTN","GMRCEDT4",222,0)
 S PLMENU="GMRCPLACEM - "_PLMENU_"PATIENT"
"RTN","GMRCEDT4",223,0)
 S PLMENU=$$FIND1^DIC(101,,"QX",PLMENU) Q:PLMENU'>1 0
"RTN","GMRCEDT4",224,0)
 Q $D(^ORD(101,PLMENU,10,"B",+PL))
"RTN","GMRCEDT4",225,0)
VALIDUR(URG,REND,PROC) ;urgency still valid?
"RTN","GMRCEDT4",226,0)
 N URMENU
"RTN","GMRCEDT4",227,0)
 I $P(REND,U)="I" D
"RTN","GMRCEDT4",228,0)
 .I 'PROC S URMENU="GMRCURGENCYM CSLT - INPATIENT" Q
"RTN","GMRCEDT4",229,0)
 .S URMENU="GMRCURGENCYM REQ - INPATIENT" Q
"RTN","GMRCEDT4",230,0)
 I '$D(URMENU) S URMENU="GMRCURGENCYM - OUTPATIENT"
"RTN","GMRCEDT4",231,0)
 S URMENU=$$FIND1^DIC(101,,"QX",URMENU) Q:URMENU<0 0
"RTN","GMRCEDT4",232,0)
 Q $D(^ORD(101,URMENU,10,"B",+URG))
"RTN","GMRCEDT4",233,0)
 Q
"RTN","GMRCEDT4",234,0)
NOCHG() ;no changes made
"RTN","GMRCEDT4",235,0)
 Q "No Changes made!"
"RTN","GMRCEDT4",236,0)
PDOK(GMRCDA) ;check validity of Prov. DX code for active status
"RTN","GMRCEDT4",237,0)
 N MSG
"RTN","GMRCEDT4",238,0)
 I '$L($G(^GMR(123,GMRCDA,30.1))) Q 1
"RTN","GMRCEDT4",239,0)
 I +$$STATCHK^ICDAPIU(^GMR(123,GMRCDA,30.1),DT) Q 1 ;code still active
"RTN","GMRCEDT4",240,0)
 S MSG="The provisional DX code must be edited before this request"
"RTN","GMRCEDT4",241,0)
 S MSG=MSG_" may be resubmitted."
"RTN","GMRCEDT4",242,0)
 D EN^DDIOL(MSG,,"!!")
"RTN","GMRCEDT4",243,0)
 Q 0
"RTN","GMRCGUIC")
0^12^B55896800
"RTN","GMRCGUIC",1,0)
GMRCGUIC ;SLC/DCM,JFR - GUI actions for editing consults; 3/13/03 12:21 ;04/29/09  11:27
"RTN","GMRCGUIC",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**4,12,20,15,22,33,66**;DEC 27, 1997;Build 30
"RTN","GMRCGUIC",3,0)
 ;
"RTN","GMRCGUIC",4,0)
 ; This routine invokes IA #2698 (ORD(101.42)), #872(ORD(101)), #2713 (ORB3F1), #3991 (ICDAPIU), #2051 (FIND1^DIC)
"RTN","GMRCGUIC",5,0)
 ;                         #2053 (DIE), #2056 (GET1^DIQ), #2690 (ORB3FUP1), #10103 (XLFDT), #10104 (XLFSTR)
"RTN","GMRCGUIC",6,0)
 ;
"RTN","GMRCGUIC",7,0)
RFQ(GMRCO,MSG,ND,NOW) ;File Reason For Request field 20
"RTN","GMRCGUIC",8,0)
 N GMRCND,GMRCNT
"RTN","GMRCGUIC",9,0)
 S GMRCND=$O(^GMR(123,GMRCO,20,0)) I GMRCND="" S GMRCFLD(20)="Reason For Request: No Previous Value^20" Q
"RTN","GMRCGUIC",10,0)
 M ^TMP("GMRCFLD20",$J,20)=^GMR(123,GMRCO,20)
"RTN","GMRCGUIC",11,0)
 S GMRCFLD(20)=$NAME(^TMP("GMRCFLD20",$J,20))
"RTN","GMRCGUIC",12,0)
 K ^GMR(123,GMRCO,20)
"RTN","GMRCGUIC",13,0)
 S ^GMR(123,GMRCO,20,0)="^^^^"_DT_"^"
"RTN","GMRCGUIC",14,0)
 S GMRCND="",GMRCNT=1 F  S GMRCND=$O(@MSG@(ND,GMRCND)) Q:GMRCND=""  S ^GMR(123,GMRCO,20,GMRCNT,0)=@MSG@(ND,GMRCND),GMRCNT=GMRCNT+1
"RTN","GMRCGUIC",15,0)
 S $P(^GMR(123,GMRCO,20,0),"^",3)=GMRCNT-1,$P(^(0),"^",4)=GMRCNT-1
"RTN","GMRCGUIC",16,0)
 Q
"RTN","GMRCGUIC",17,0)
FILE(GMRCO,MSG,GMRCLM) ;File Edit changes
"RTN","GMRCGUIC",18,0)
 ;GMRCO=Record IEN,  GMRCCOM=Comment Array
"RTN","GMRCGUIC",19,0)
 ;MSG=^TMP global where the data resides, i.e., MSG="^TMP(""GMRCR"",$J)"
"RTN","GMRCGUIC",20,0)
 ;    Data is stored in subscripted nodes: ^TMP("GMRCR",$J,1)="GMRCSS^2"
"RTN","GMRCGUIC",21,0)
 ;    Word processing data is stored in second subscripted node:
"RTN","GMRCGUIC",22,0)
 ;    ^TMP("GMRCR",$J,9,1)="This is word processing data."
"RTN","GMRCGUIC",23,0)
 ;GMRCSS=To Service     GMRCPROC=procedure/Request Type
"RTN","GMRCGUIC",24,0)
 ;GMRCURG=Urgency       GMRCPL=Place Of Consultation
"RTN","GMRCGUIC",25,0)
 ;GMRCATN=Attention To  GMRCINO=Service is In/Out Patient
"RTN","GMRCGUIC",26,0)
 ;GMRCDIAG=Provisional Diagnosis  .GMRCRFQ=Reason For Request array
"RTN","GMRCGUIC",27,0)
 ;GMRCREQ=Procedure or Request; i.e., GMRCRQT=1727=^ORD(101,1727,0)='Procedure';GMRCRQT=1296=^ORD(101,1296,0)='Consult'
"RTN","GMRCGUIC",28,0)
 ;GMRCITM=Item ordered for field .1 (stored in ^GMR(123,GMRCO,1.11,
"RTN","GMRCGUIC",29,0)
 ;GMRCLM=coming from List Manager instead of the GUI
"RTN","GMRCGUIC",30,0)
 ;GMRCERDT=Earliest Appropriate Date WAT/66
"RTN","GMRCGUIC",31,0)
 ;
"RTN","GMRCGUIC",32,0)
 I '$D(GMRCO)!('+GMRCO) Q
"RTN","GMRCGUIC",33,0)
 N GMRCSS,GMRCPROC,GMRCURG,GMRCPL,GMRCATN,GMRCRQT
"RTN","GMRCGUIC",34,0)
 N GMRCION,GMRCDIAG,GMRCDXCD,GMRCACTN,GMRCERDT
"RTN","GMRCGUIC",35,0)
 S GMRCDT=$$NOW^XLFDT
"RTN","GMRCGUIC",36,0)
 S GMRCMSG="",GMRCNOD=0
"RTN","GMRCGUIC",37,0)
 F  S GMRCNOD=$O(@MSG@(GMRCNOD)) Q:GMRCNOD=""  S GMRCMSG=@MSG@(GMRCNOD) D
"RTN","GMRCGUIC",38,0)
 .I $P(GMRCMSG,"^",1)="COMMENT" D COMMENT^GMRCGUIU(GMRCO,MSG,GMRCNOD,$P(GMRCMSG,"^",2)) Q
"RTN","GMRCGUIC",39,0)
 .I $P(GMRCMSG,"^",1)="GMRCRFQ" D RFQ(GMRCO,MSG,GMRCNOD,GMRCDT) Q
"RTN","GMRCGUIC",40,0)
 .I $P(GMRCMSG,"^",1)="GMRCSS" S GMRCSS=$P(GMRCMSG,"^",2),GMRCFLD(1)=$P(^GMR(123.5,$P(^GMR(123,GMRCO,0),"^",5),0),"^",1)_"^1" Q
"RTN","GMRCGUIC",41,0)
 .I $P(GMRCMSG,"^",1)="GMRCITM" S GMRCITM=$P(GMRCMSG,"^",2),GMRCFLD(.1)=^GMR(123,GMRCO,1.11)_"^.1" Q
"RTN","GMRCGUIC",42,0)
 .I $P(GMRCMSG,"^",1)="GMRCPROC" Q  ;S GMRCFLD(4)=+$P(^GMR(123,+GMRCO,0),"^",8)_"^4" D  Q ;ignore procedure, can't be changed currently
"RTN","GMRCGUIC",43,0)
 .; ..S GMRCPROC=$P(GMRCMSG,"^",2) I $L($P(^GMR(123,GMRCO,0),"^",8)),$P(GMRCMSG,"^",2)="" S GMRCPROC="DELETE"
"RTN","GMRCGUIC",44,0)
 .I $P(GMRCMSG,"^",1)="GMRCURG" S GMRCURG=$P(GMRCMSG,"^",2),GMRCFLD(5)=$S(+$P(^GMR(123,+GMRCO,0),"^",9):$P(^ORD(101,+$P(^GMR(123,+GMRCO,0),"^",9),0),"^",2),1:"")_"^"_$P(^GMR(123,+GMRCO,0),"^",9) Q
"RTN","GMRCGUIC",45,0)
 .I $P(GMRCMSG,"^",1)="GMRCPL" D  Q
"RTN","GMRCGUIC",46,0)
 ..S GMRCPL=$P(GMRCMSG,"^",2) I '+GMRCPL D
"RTN","GMRCGUIC",47,0)
 ...S GMRCPL="GMRCPLACE - "_$S(GMRCPL="C":"ON CALL",GMRCPL="B":"BEDSIDE",GMRCPL="E":"EMERGENCY ROOM",1:GMRCPL),GMRCPL=$O(^ORD(101,"B",GMRCPL,0))
"RTN","GMRCGUIC",48,0)
 ..S GMRCFLD(6)=$S(+$P(^GMR(123,+GMRCO,0),"^",10):$P($P(^ORD(101,+$P(^GMR(123,+GMRCO,0),"^",10),0),"^",1)," - ",2),1:"")_"^6"
"RTN","GMRCGUIC",49,0)
 ..Q
"RTN","GMRCGUIC",50,0)
 .I $P(GMRCMSG,"^",1)="GMRCATN" S GMRCATN=$P(GMRCMSG,"^",2),GMRCFLD(7)=$S(+$P(^GMR(123,+GMRCO,0),"^",11):$$GET1^DIQ(200,+$P(^GMR(123,+GMRCO,0),"^",11),.01),1:"")_"^7" Q
"RTN","GMRCGUIC",51,0)
 .I $P(GMRCMSG,"^",1)="GMRCREQ" S GMRCREQ=$P(GMRCMSG,"^",2),GMRCFLD(13)=$S($P(^GMR(123,+GMRCO,0),"^",17)="P":"Procedure",1:"Consult")_"^13" Q
"RTN","GMRCGUIC",52,0)
 .I $P(GMRCMSG,"^",1)="GMRCION" S GMRCION=$P(GMRCMSG,"^",2),GMRCFLD(14)=$S($P(^GMR(123,+GMRCO,0),"^",18)="I":"Inpatient",$P(^(0),"^",18)="O":"Outpatient",1:"")_"^14" Q
"RTN","GMRCGUIC",53,0)
 .I $P(GMRCMSG,"^",1)="GMRCERDT" S GMRCERDT=$P(GMRCMSG,"^",2),GMRCFLD(17)=$S(+$P(^GMR(123,+GMRCO,0),"^",24)>0:$$FMTE^XLFDT($P(^GMR(123,+GMRCO,0),"^",24)),1:"")_"^17" Q
"RTN","GMRCGUIC",54,0)
 .I $P(GMRCMSG,"^",1)="GMRCDIAG" D  Q
"RTN","GMRCGUIC",55,0)
 ..S GMRCDIAG=$P(GMRCMSG,"^",2)
"RTN","GMRCGUIC",56,0)
 ..S GMRCFLD(30)=$G(^GMR(123,+GMRCO,30))_"^30"
"RTN","GMRCGUIC",57,0)
 ..I $P(GMRCFLD(30),U)="" S $P(GMRCFLD(30),U)="No Previous Value"
"RTN","GMRCGUIC",58,0)
 ..I $L($P(GMRCMSG,U,3)) D
"RTN","GMRCGUIC",59,0)
 ...S GMRCDXCD=$P(GMRCMSG,"^",3)
"RTN","GMRCGUIC",60,0)
 ...S GMRCFLD(30.1)=$G(^GMR(123,+GMRCO,30.1))
"RTN","GMRCGUIC",61,0)
 .Q
"RTN","GMRCGUIC",62,0)
 S:'$D(GMRCLM) GMRCGUIF=1
"RTN","GMRCGUIC",63,0)
 S GMRCACTN=$$EN^GMRCEDT3(GMRCO)
"RTN","GMRCGUIC",64,0)
 S DR=$$SETDA^GMRCGUIU($G(GMRCSS),$G(GMRCPROC),$G(GMRCURG),$G(GMRCPL),$G(GMRCATN),$G(GMRCRQT),$G(GMRCION),$G(GMRCERDT),$G(GMRCDIAG),$G(GMRCDXCD)) I $L(DR) D
"RTN","GMRCGUIC",65,0)
 .S DIE="^GMR(123,",DA=GMRCO
"RTN","GMRCGUIC",66,0)
 .L +^GMR(123,GMRCO):$S($G(DILOCKTM)>0:DILOCKTM,1:5) ;WAT/66 added timeout
"RTN","GMRCGUIC",67,0)
 .D ^DIE
"RTN","GMRCGUIC",68,0)
 .S DR="8////^S X=5;9////^S X=11"
"RTN","GMRCGUIC",69,0)
 .D ^DIE
"RTN","GMRCGUIC",70,0)
 .L -^GMR(123,GMRCO)
"RTN","GMRCGUIC",71,0)
 .K DIE,DR,DA
"RTN","GMRCGUIC",72,0)
 .Q
"RTN","GMRCGUIC",73,0)
 S DFN=$P(^GMR(123,+GMRCO,0),"^",2),GMRCPROV=$P(^(0),"^",14),GMRCTYPE=$P(^(0),"^",17),GMRCTRLC="XX^RESUBMIT",VISIT="",RMBED=""
"RTN","GMRCGUIC",74,0)
 D EN^GMRCHL7(DFN,+GMRCO,GMRCTYPE,RMBED,GMRCTRLC,$G(DUZ),VISIT,.GMRCOM)
"RTN","GMRCGUIC",75,0)
 S GMRCSVC=$S($G(GMRCSS):GMRCSS,1:$P(^GMR(123,+GMRCO,0),U,5))
"RTN","GMRCGUIC",76,0)
 S GMRCORTX="Resubmitted consult "_$$ORTX^GMRCAU(+GMRCO)
"RTN","GMRCGUIC",77,0)
 S GMRCORTX=GMRCORTX_$S($G(GMRCURG):" ("_$P(^ORD(101,+GMRCURG,0),"^",2)_")",+$P(^GMR(123,+GMRCO,0),U,9):"( "_$P(^ORD(101,+$P(^GMR(123,+GMRCO,0),U,9),0),"^",2)_" )",1:"")
"RTN","GMRCGUIC",78,0)
 S GMRCFL=1
"RTN","GMRCGUIC",79,0)
 D MSG^GMRCP(DFN,GMRCORTX,+GMRCO,27,.GMRCADUZ,GMRCFL) ;Send notification of NEW consult
"RTN","GMRCGUIC",80,0)
 D PRNT^GMRCUTL1(+$P(^GMR(123,+GMRCO,0),U,5),+GMRCO) ;send 513 to service
"RTN","GMRCGUIC",81,0)
 ;Next line gets rid of alert
"RTN","GMRCGUIC",82,0)
 I $D(XQAID),$L(XQAID) D
"RTN","GMRCGUIC",83,0)
 . N GMRCCORY
"RTN","GMRCGUIC",84,0)
 . S XQAKILL=$$XQAKILL^ORB3F1 D DEL^ORB3FUP1(.GMRCCORY,XQAID)
"RTN","GMRCGUIC",85,0)
 I $P($G(^GMR(123,+GMRCO,12)),U,5)="P" D
"RTN","GMRCGUIC",86,0)
 . D TRIGR^GMRCIEVT(GMRCO,GMRCACTN)
"RTN","GMRCGUIC",87,0)
 D GUIC^GMRCGUIU
"RTN","GMRCGUIC",88,0)
 Q
"RTN","GMRCGUIC",89,0)
SEND(GMRCO,GLOBAL) ;Get data fields to send to GUI for editing consult
"RTN","GMRCGUIC",90,0)
 ;GMRCO=record being edited GLOBAL=Global Referece, i.e., "^TMP("GMRCR",$J)"
"RTN","GMRCGUIC",91,0)
 K @GLOBAL
"RTN","GMRCGUIC",92,0)
 N ND,GMRCSX,TYPE,NDX
"RTN","GMRCGUIC",93,0)
 S ND=1,GMRCSX=""
"RTN","GMRCGUIC",94,0)
 I '$D(GMRCO)!('+GMRCO) Q
"RTN","GMRCGUIC",95,0)
 S GMRC(0)=$G(^GMR(123,+GMRCO,0)) Q:'$L(GMRC(0))
"RTN","GMRCGUIC",96,0)
 S GMRCSS=$P(GMRC(0),"^",5),GMRCPROC=$P(GMRC(0),"^",8)
"RTN","GMRCGUIC",97,0)
 S GMRCURG=$P(GMRC(0),"^",9),GMRCPL=$P(GMRC(0),"^",10)
"RTN","GMRCGUIC",98,0)
 S GMRCATN=$P(GMRC(0),"^",11),GMRCINO=$P(GMRC(0),"^",18)
"RTN","GMRCGUIC",99,0)
 S GMRCREQ=$P(GMRC(0),"^",17),GMRCERDT=$P(GMRC(0),"^",24)
"RTN","GMRCGUIC",100,0)
 S GMRCDIAG=$G(^GMR(123,+GMRCO,30)) I $L($G(^(30.1))) D
"RTN","GMRCGUIC",101,0)
 . S GMRCDIAG=GMRCDIAG_U_$G(^GMR(123,+GMRCO,30.1))
"RTN","GMRCGUIC",102,0)
 . I '$$STATCHK^ICDAPIU($P(GMRCDIAG,U,2),DT) S GMRCDIAG=GMRCDIAG_U_1
"RTN","GMRCGUIC",103,0)
 S GMRCPROV=$S($P(^GMR(123,+GMRCO,0),U,14):$$GET1^DIQ(200,+$P(^(0),U,14),.01),1:"")
"RTN","GMRCGUIC",104,0)
 S @GLOBAL@(ND,0)="~SERVICE",ND=ND+1
"RTN","GMRCGUIC",105,0)
 I +GMRCSS S GMRCSX=$P(^GMR(123.5,GMRCSS,0),"^",1),@GLOBAL@(ND,0)="d"_GMRCSX_"^"_GMRCSS_"^",ND=ND+1,GMRCSX=""
"RTN","GMRCGUIC",106,0)
 E  S @GLOBAL@(ND,0)="d"_"^^",ND=ND+1
"RTN","GMRCGUIC",107,0)
 S @GLOBAL@(ND,0)="~PROCEDURE",ND=ND+1
"RTN","GMRCGUIC",108,0)
 I $L(GMRCPROC),+GMRCPROC D
"RTN","GMRCGUIC",109,0)
 .S GMRCSX=$$UP^XLFSTR($$GET1^DIQ(123.3,+GMRCPROC,.01))
"RTN","GMRCGUIC",110,0)
 .S GMRCSY=$$FIND1^DIC(101.43,,"QX",+GMRCPROC_";99PRC","ID")
"RTN","GMRCGUIC",111,0)
 .I +GMRCSY D
"RTN","GMRCGUIC",112,0)
 ..S @GLOBAL@(ND,0)="d"_GMRCSY_"^"_GMRCSX,ND=ND+1
"RTN","GMRCGUIC",113,0)
 ..Q
"RTN","GMRCGUIC",114,0)
 E  S @GLOBAL@(ND,0)="d^^"
"RTN","GMRCGUIC",115,0)
 S @GLOBAL@(ND,0)="~TYPE",ND=ND+1
"RTN","GMRCGUIC",116,0)
 I $L(GMRCREQ) D  I '$L(GMRCREQ) S @GLOBAL@(ND,0)="d^^"
"RTN","GMRCGUIC",117,0)
 . S GMRCSX=$S(GMRCREQ="P":"PROCEDURE",1:"CONSULT")
"RTN","GMRCGUIC",118,0)
 . S @GLOBAL@(ND,0)="d"_$E(GMRCSX,1)_"^"_GMRCSX_"^"_GMRCREQ
"RTN","GMRCGUIC",119,0)
 . S GMRCSX=""
"RTN","GMRCGUIC",120,0)
 S ND=ND+1
"RTN","GMRCGUIC",121,0)
 S @GLOBAL@(ND,0)="~CATEGORY",ND=ND+1
"RTN","GMRCGUIC",122,0)
 I $L(GMRCINO) D  S ND=ND+1,GMRCSX=""
"RTN","GMRCGUIC",123,0)
 .S @GLOBAL@(ND,0)="d"_GMRCINO_"^"_$S(GMRCINO="I":"INPATIENT",1:"OUTPATIENT")_"^"
"RTN","GMRCGUIC",124,0)
 .S @GLOBAL@(ND,0)=@GLOBAL@(ND,0)_$S(GMRCINO="I":$O(^ORD(101,"B","GMRCURGENCYM CSLT - INPATIENT",0)),1:$O(^ORD(101,"B","GMRCURGENCYM - OUTPATIENT",0)))
"RTN","GMRCGUIC",125,0)
 .Q
"RTN","GMRCGUIC",126,0)
 E  S @GLOBAL@(ND,0)="d^^"
"RTN","GMRCGUIC",127,0)
 S @GLOBAL@(ND,0)="~DIAGNOSIS",ND=ND+1
"RTN","GMRCGUIC",128,0)
 I $L(GMRCDIAG) S @GLOBAL@(ND,0)="d"_GMRCDIAG,ND=ND+1
"RTN","GMRCGUIC",129,0)
 E  S @GLOBAL@(ND,0)="d"
"RTN","GMRCGUIC",130,0)
 S @GLOBAL@(ND,0)="~PLACE",ND=ND+1
"RTN","GMRCGUIC",131,0)
 I +GMRCPL D  S ND=ND+1,GMRCSX=""
"RTN","GMRCGUIC",132,0)
 .S GMRCSX=$P($P(^ORD(101,GMRCPL,0),"^",1),"GMRCPLACE - ",2),GMRCSX=$S(GMRCSX="ON CALL":"CONSULTANTS CHOICE",1:GMRCSX),@GLOBAL@(ND,0)="d"_$E(GMRCSX,1)_"^"_GMRCSX_"^"_GMRCPL
"RTN","GMRCGUIC",133,0)
 .Q
"RTN","GMRCGUIC",134,0)
 E  S @GLOBAL@(ND,0)="d^^",ND=ND+1
"RTN","GMRCGUIC",135,0)
 S @GLOBAL@(ND,0)="~ATTENTION",ND=ND+1
"RTN","GMRCGUIC",136,0)
 I +GMRCATN S GMRCSX=$$GET1^DIQ(200,GMRCATN,.01),@GLOBAL@(ND,0)="d"_GMRCATN_"^"_GMRCSX_"^"_GMRCATN,ND=ND+1,GMRCSX=""
"RTN","GMRCGUIC",137,0)
 E  S @GLOBAL@(ND,0)="d^^",ND=ND+1
"RTN","GMRCGUIC",138,0)
 S @GLOBAL@(ND,0)="~EARLIEST",ND=ND+1 ;WAT/66
"RTN","GMRCGUIC",139,0)
 I GMRCERDT S @GLOBAL@(ND,0)="d"_"^"_GMRCERDT,ND=ND+1 ;WAT66
"RTN","GMRCGUIC",140,0)
 E  S @GLOBAL@(ND,0)="d^" ;WAT
"RTN","GMRCGUIC",141,0)
 S @GLOBAL@(ND,0)="~URGENCY",ND=ND+1
"RTN","GMRCGUIC",142,0)
 I +GMRCURG S GMRCSX=$P($P(^ORD(101,GMRCURG,0),"^",1),"GMRCURGENCY - ",2),GMRCURGY=$O(^ORD(101.42,"S.GMRCO",GMRCSX,0)) I $L(GMRCSX) D
"RTN","GMRCGUIC",143,0)
 .S GMRCSY=$O(^ORD(101.42,"B",GMRCSX,0))
"RTN","GMRCGUIC",144,0)
 .S @GLOBAL@(ND,0)="d"_GMRCSY_"^"_GMRCSX_"^"_GMRCURG,ND=ND+1
"RTN","GMRCGUIC",145,0)
 .S GMRCSX="" K GMRCSY
"RTN","GMRCGUIC",146,0)
 .Q
"RTN","GMRCGUIC",147,0)
 E  S @GLOBAL@(ND,0)="d^^",ND=ND+1
"RTN","GMRCGUIC",148,0)
 ;Get reason for request
"RTN","GMRCGUIC",149,0)
 S @GLOBAL@(ND,0)="~REASON",ND=ND+1
"RTN","GMRCGUIC",150,0)
 I $O(^GMR(123,+GMRCO,20,0)) S NDX=0 F  S NDX=$O(^GMR(123,+GMRCO,20,NDX)) Q:NDX=""  S @GLOBAL@(ND,0)="t"_^GMR(123,+GMRCO,20,NDX,0),ND=ND+1
"RTN","GMRCGUIC",151,0)
 E  S @GLOBAL@(ND,0)="~REASON",ND=ND+1,@GLOBAL@(ND,0)="tREASON "
"RTN","GMRCGUIC",152,0)
 ;Get Comments, including Deny Comments
"RTN","GMRCGUIC",153,0)
 D SENDCOMT^GMRCGUIU(GMRCO,.ND)
"RTN","GMRCGUIC",154,0)
 D GUIC^GMRCGUIU
"RTN","GMRCGUIC",155,0)
 Q
"RTN","GMRCGUIU")
0^13^B30098345
"RTN","GMRCGUIU",1,0)
GMRCGUIU ;SLC/DCM,JFR - Utilities for CPRS GUI ;04/23/09  13:25
"RTN","GMRCGUIU",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,17,22,66**;DEC 27, 1997;Build 30
"RTN","GMRCGUIU",3,0)
 ;
"RTN","GMRCGUIU",4,0)
 ; This routine invokes IA #2757(EN^MCARPS2), #3042 (SINGLE^MCAPI), #3171 (START^ORWRP)
"RTN","GMRCGUIU",5,0)
 ;                         #(GET1^DIQ), #3280 (MEDLKUP^MCARUTL3), #10103 (XLFDT)
"RTN","GMRCGUIU",6,0)
 ;
"RTN","GMRCGUIU",7,0)
GUIC ;Kill variables from GMRCGUIC
"RTN","GMRCGUIU",8,0)
 K GMRC(0),GMRCA,GMRCATN,GMRCD,GMRCDD,GMRCDIAG,GMRCDT,GMRCED,GMRCEDCM
"RTN","GMRCGUIU",9,0)
 K GMRCFL,GMRCFLD,GMRCION,GMRCLNO,GMRCNATO,GMRCNT,GMRCORTX,GMRCPL
"RTN","GMRCGUIU",10,0)
 K GMRCPROC,GMRCRQT,GMRCS38,GMRCSS,GMRCSVC,GMRCTRLC,GMRCTYPE,GMRCURG
"RTN","GMRCGUIU",11,0)
 K GMRCX,LN,GMRCADUZ,ORDG,RMBED,VISIT
"RTN","GMRCGUIU",12,0)
 K GMRCITM,GMRCMSG,GMRCND1,GMRCNOD,GMRCPROV,GMRCOUNT,GMRCGUIF,GMRCREQ
"RTN","GMRCGUIU",13,0)
 K GMRCSS,GMRCPROC,GMRCURG,GMRCURGY,GMRCPL,GMRCATN,GMRCINO,GMRCREQ
"RTN","GMRCGUIU",14,0)
 K GMRCDIAG,GMRCDXCD,GMRCPROV,ND,NDX
"RTN","GMRCGUIU",15,0)
 K XQAKILL,^TMP("GMRCFLD20",$J)
"RTN","GMRCGUIU",16,0)
 Q
"RTN","GMRCGUIU",17,0)
SETDA(GMRCSS,GMRCPROC,GMRCURG,GMRCPL,GMRCATN,GMRCRQT,GMRCION,GMRCERDT,GMRCDIAG,GMRCDXCD)  ;Set DA in ^GMR(123,GMRCO,40
"RTN","GMRCGUIU",18,0)
 ;WAT/66 added earliest date
"RTN","GMRCGUIU",19,0)
 N X
"RTN","GMRCGUIU",20,0)
 S X=""
"RTN","GMRCGUIU",21,0)
 I +GMRCSS S X="1////^S X=+GMRCSS;.1///@;"
"RTN","GMRCGUIU",22,0)
 I +GMRCPROC S X=X_"4////^S X=GMRCPROC;.1///@;"
"RTN","GMRCGUIU",23,0)
 I +GMRCURG S X=X_"5////^S X=GMRCURG;"
"RTN","GMRCGUIU",24,0)
 I +GMRCPL S X=X_"6////^S X=GMRCPL;"
"RTN","GMRCGUIU",25,0)
 I +GMRCATN S X=X_"7////^S X=GMRCATN;"
"RTN","GMRCGUIU",26,0)
 I $G(GMRCATN)="@" S X=X_"7///@;"
"RTN","GMRCGUIU",27,0)
 I $L(GMRCION) S X=X_"14///^S X=GMRCION;"
"RTN","GMRCGUIU",28,0)
 I +GMRCERDT S X=X_"17///^S X=GMRCERDT;"
"RTN","GMRCGUIU",29,0)
 I $L(GMRCDIAG) D
"RTN","GMRCGUIU",30,0)
 . I GMRCDIAG="@" S X=X_"30///@;30.1///@;" Q
"RTN","GMRCGUIU",31,0)
 . S X=X_"30////^S X=GMRCDIAG;"
"RTN","GMRCGUIU",32,0)
 I $L(GMRCDXCD) S X=X_"30.1////^S X=GMRCDXCD;"
"RTN","GMRCGUIU",33,0)
 I $L(X) S X=$E(X,1,$L(X)-1)
"RTN","GMRCGUIU",34,0)
 Q X
"RTN","GMRCGUIU",35,0)
 ;
"RTN","GMRCGUIU",36,0)
COMMENT(GMRCO,MSG,ND,GMRCDA)    ;File comments from GUI edits
"RTN","GMRCGUIU",37,0)
 N Y,GMRCND
"RTN","GMRCGUIU",38,0)
 S GMRCDA=$$ADDCM^GMRCEDT3(GMRCO),GMRCA=20
"RTN","GMRCGUIU",39,0)
 D AUDIT0^GMRCEDT3(GMRCDA,GMRCO)
"RTN","GMRCGUIU",40,0)
 S Y=$$FMTE^XLFDT(DT,"1D"),GMRCFLD(40)="COMMENT ADDED: "_Y_"^"_GMRCDA
"RTN","GMRCGUIU",41,0)
 S GMRCND="",GMRCNT=1 F  S GMRCND=$O(@MSG@(ND,GMRCND)) Q:GMRCND=""  S ^GMR(123,GMRCO,40,GMRCDA,1,GMRCNT,0)=@MSG@(ND,GMRCND),GMRCNT=GMRCNT+1
"RTN","GMRCGUIU",42,0)
 S ^GMR(123,GMRCO,40,GMRCDA,1,0)="^^"_(GMRCNT-1)_"^"_(GMRCNT-1)_"^"_GMRCDT_"^"
"RTN","GMRCGUIU",43,0)
 I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D
"RTN","GMRCGUIU",44,0)
 . D TRIGR^GMRCIEVT(GMRCO,GMRCDA)
"RTN","GMRCGUIU",45,0)
 Q
"RTN","GMRCGUIU",46,0)
 ;
"RTN","GMRCGUIU",47,0)
SENDCOMT(GMRCO,ND1)     ;Get comments   ;wat/66 replaced ^VA(200 with $$GET1^DIQ
"RTN","GMRCGUIU",48,0)
 N NDX,NDY,CMTDT,SENDR,TYPE
"RTN","GMRCGUIU",49,0)
 S NDX=0,CMTDT="",SENDR=""
"RTN","GMRCGUIU",50,0)
 S NDX=0 F  S NDX=$O(^GMR(123,GMRCO,40,NDX)) Q:NDX?1A.E!(NDX="")  S TYPE=$P(^GMR(123,GMRCO,40,NDX,0),"^",2) I $S(TYPE=19:1,TYPE=20:1,1:0) S TYPE(TYPE,NDX)=""
"RTN","GMRCGUIU",51,0)
 I $O(TYPE(19,0)) S @GLOBAL@(ND1,0)="~DENY COMMENT",ND1=ND1+1 D
"RTN","GMRCGUIU",52,0)
 .S NDX=0 F  S NDX=$O(TYPE(19,NDX)) Q:NDX=""   D
"RTN","GMRCGUIU",53,0)
 ..S CMTDT=$$FMTE^XLFDT($P(^GMR(123,GMRCO,40,NDX,0),"^",1)),SENDR=$S($L($P(^GMR(123,GMRCO,40,NDX,0),"^",4)):$$GET1^DIQ(200,$P(^(0),"^",4),.01),1:"Missing Data")
"RTN","GMRCGUIU",54,0)
 ..S @GLOBAL@(ND1,0)="t"_"CANCELLED: "_CMTDT_" BY: "_SENDR,ND1=ND1+1,NDY=0
"RTN","GMRCGUIU",55,0)
 ..S NDY=0 F  S NDY=$O(^GMR(123,GMRCO,40,NDX,1,NDY)) Q:NDY=""  S @GLOBAL@(ND1,0)="t"_^GMR(123,GMRCO,40,NDX,1,NDY,0),ND1=ND1+1
"RTN","GMRCGUIU",56,0)
 ..S @GLOBAL@(ND1,0)="t",$P(@GLOBAL@(ND1,0),"-",81)="",ND1=ND1+1
"RTN","GMRCGUIU",57,0)
 ..Q
"RTN","GMRCGUIU",58,0)
 .Q
"RTN","GMRCGUIU",59,0)
 S NDX=0 F  S NDX=$O(TYPE(20,NDX)) Q:NDX=""  S @GLOBAL@(ND1,0)="~ADDED COMMENT",ND1=ND1+1 D
"RTN","GMRCGUIU",60,0)
 .S CMTDT=$$FMTE^XLFDT($P(^GMR(123,GMRCO,40,NDX,0),"^",1)),SENDR=$S($L($P(^GMR(123,GMRCO,40,NDX,0),"^",4)):$$GET1^DIQ(200,$P(^(0),"^",4),.01),1:"UNKNOWN")
"RTN","GMRCGUIU",61,0)
 .S @GLOBAL@(ND1,0)="t"_"COMMENT on "_CMTDT_" BY: "_SENDR,ND1=ND1+1
"RTN","GMRCGUIU",62,0)
 .S NDY=0 F  S NDY=$O(^GMR(123,GMRCO,40,NDX,1,NDY)) Q:NDY=""  S @GLOBAL@(ND,0)="t"_^GMR(123,GMRCO,40,NDX,1,NDY,0),ND1=ND1+1
"RTN","GMRCGUIU",63,0)
 .S @GLOBAL@(ND1,0)="t",$P(@GLOBAL@(ND1,0),"-",81)="",ND1=ND1+1
"RTN","GMRCGUIU",64,0)
 .Q
"RTN","GMRCGUIU",65,0)
 Q
"RTN","GMRCGUIU",66,0)
GETMED(GMRCIFN,GMRCRES) ;return available med results for proc request
"RTN","GMRCGUIU",67,0)
 ; input:
"RTN","GMRCGUIU",68,0)
 ;    GMRCIFN - ien from file 123
"RTN","GMRCGUIU",69,0)
 ;    GMRCRES - variable passed in by reference used for output
"RTN","GMRCGUIU",70,0)
 ; output:
"RTN","GMRCGUIU",71,0)
 ;     GMRCRES(x) = result_name^date^summary^result_ref
"RTN","GMRCGUIU",72,0)
 ;      example:
"RTN","GMRCGUIU",73,0)
 ;       GMRCRES(1)="19;MCAR(691.5,^EKG^JUN 30,1999@15:52^ABNORMAL"
"RTN","GMRCGUIU",74,0)
 N CNT,ROOT,PROC,S5,DFN,I
"RTN","GMRCGUIU",75,0)
 N MCARCODE,MCARDT,MCESKEY,MCKEYCAR,MCFILE
"RTN","GMRCGUIU",76,0)
 S PROC=+$P($G(^GMR(123,GMRCIFN,0)),U,8)
"RTN","GMRCGUIU",77,0)
 I 'PROC Q  ;no procedure there
"RTN","GMRCGUIU",78,0)
 S ROOT=$$GET1^DIQ(697.2,+$P(^GMR(123.3,PROC,0),U,5),1)
"RTN","GMRCGUIU",79,0)
 I '$L(ROOT) Q  ;proc not set up for med resulting
"RTN","GMRCGUIU",80,0)
 S S5=ROOT D EN^MCARPS2(+$P(^GMR(123,GMRCIFN,0),U,2))
"RTN","GMRCGUIU",81,0)
 I '$D(^TMP("OR",$J,"MCAR","OT")) Q  ;no results available
"RTN","GMRCGUIU",82,0)
 S CNT=0,I=0
"RTN","GMRCGUIU",83,0)
 F  S CNT=$O(^TMP("OR",$J,"MCAR","OT",CNT)) Q:'CNT  D
"RTN","GMRCGUIU",84,0)
 . N DATA S DATA=^TMP("OR",$J,"MCAR","OT",CNT)
"RTN","GMRCGUIU",85,0)
 . Q:$D(^GMR(123,"R",$P(DATA,U,2)_";"_ROOT_","))
"RTN","GMRCGUIU",86,0)
 . Q:$$SCRNDRFT^GMRCMED($P(DATA,U,2),$P(ROOT,"(",2))  ;screen draft rpts
"RTN","GMRCGUIU",87,0)
 . S I=I+1
"RTN","GMRCGUIU",88,0)
 . S GMRCRES(I)=$P(DATA,U,2)_";"_ROOT_","_U_$P(DATA,U)_U_$P(DATA,U,6,7)
"RTN","GMRCGUIU",89,0)
 . Q
"RTN","GMRCGUIU",90,0)
 K MCARCODE,MCARDT,MCESKEY,MCKEYCAR,MCFILE
"RTN","GMRCGUIU",91,0)
 K ^TMP("OR",$J,"MCAR")
"RTN","GMRCGUIU",92,0)
 Q
"RTN","GMRCGUIU",93,0)
GETRES(GMRCO,GMRCAR) ;return array of associated med rslts
"RTN","GMRCGUIU",94,0)
 ; DBIA #: ?
"RTN","GMRCGUIU",95,0)
 ; Input:
"RTN","GMRCGUIU",96,0)
 ;   GMRCO - ien from file 123
"RTN","GMRCGUIU",97,0)
 ;   GMRCAR - variable passed by ref to return array in
"RTN","GMRCGUIU",98,0)
 ; Output:
"RTN","GMRCGUIU",99,0)
 ;   GMRCAR(x)=result_ref^result_name^date^impression
"RTN","GMRCGUIU",100,0)
 ;    Example:
"RTN","GMRCGUIU",101,0)
 ;      GMRCAR(1)="19;MCAR(691.5,^EKG^JUN 30,1999@15:52^ABNORMAL"
"RTN","GMRCGUIU",102,0)
 N RES,CNT,DATA
"RTN","GMRCGUIU",103,0)
 S RES=0,CNT=1
"RTN","GMRCGUIU",104,0)
 F  S RES=$O(^GMR(123,GMRCO,50,RES)) Q:'RES  D
"RTN","GMRCGUIU",105,0)
 . N GMRCMCR,GMRCMCAR,RES0
"RTN","GMRCGUIU",106,0)
 . S RES0=$G(^GMR(123,GMRCO,50,RES,0))
"RTN","GMRCGUIU",107,0)
 . I RES0'["MCAR" Q
"RTN","GMRCGUIU",108,0)
 . S GMRCMCR=$$SINGLE^MCAPI(RES0)
"RTN","GMRCGUIU",109,0)
 . Q:'$L(GMRCMCR)
"RTN","GMRCGUIU",110,0)
 . D MEDLKUP^MCARUTL3(.GMRCMCAR,+$P(RES0,"MCAR(",2),+RES0)
"RTN","GMRCGUIU",111,0)
 . S GMRCAR(CNT)=^GMR(123,GMRCO,50,RES,0)_U
"RTN","GMRCGUIU",112,0)
 . S GMRCAR(CNT)=GMRCAR(CNT)_$P(GMRCMCR,U)_U_$P(GMRCMCR,U,6,7)
"RTN","GMRCGUIU",113,0)
 . I $P(GMRCMCAR,U,10) S GMRCAR(CNT)=GMRCAR(CNT)_"^1"
"RTN","GMRCGUIU",114,0)
 . S CNT=CNT+1
"RTN","GMRCGUIU",115,0)
 . Q
"RTN","GMRCGUIU",116,0)
 Q
"RTN","GMRCGUIU",117,0)
DISPMED(GMRCRES,GMRCAR) ; display a med result
"RTN","GMRCGUIU",118,0)
 ; Input:
"RTN","GMRCGUIU",119,0)
 ;  GMRCRES - med result var ptr  (e.g. "19;MCAR(691.5")
"RTN","GMRCGUIU",120,0)
 ;  GMRCAR  - array to return output from medicine API
"RTN","GMRCGUIU",121,0)
 ; Output:
"RTN","GMRCGUIU",122,0)
 ;  GMRCAR
"RTN","GMRCGUIU",123,0)
 ;    - var passed by ref or as global ref to return text of
"RTN","GMRCGUIU",124,0)
 ;      medicine pkg report
"RTN","GMRCGUIU",125,0)
 ;    Example:  GMRCAR(1)="      PROCEDURE DATE/TIME: 06/30/99 15:52"
"RTN","GMRCGUIU",126,0)
 ;              GMRCAR(2)="        CONFIDENTIAL ECG REPORT"
"RTN","GMRCGUIU",127,0)
 ;              GMRCAR(3...)=
"RTN","GMRCGUIU",128,0)
 D START^ORWRP(80,"EN^MCAPI(GMRCRES,1)")
"RTN","GMRCGUIU",129,0)
 I '$D(^TMP("ORDATA",$J,1)) D  Q
"RTN","GMRCGUIU",130,0)
 . I $D(GMRCAR) S @GMRCAR@(1)="Unable to locate result." Q
"RTN","GMRCGUIU",131,0)
 . I '$D(GMRCAR) S GMRCAR(1)="Unable to locate result."
"RTN","GMRCGUIU",132,0)
 I $D(GMRCAR) M @GMRCAR=^TMP("ORDATA",$J,1)
"RTN","GMRCGUIU",133,0)
 I '$D(GMRCAR) M GMRCAR=^TMP("ORDATA",$J,1)
"RTN","GMRCGUIU",134,0)
 K ^TMP("ORDATA",$J,1)
"RTN","GMRCGUIU",135,0)
 Q
"RTN","GMRCGUIU",136,0)
CANDOMED(GMRCIEN,USER) ;can person associate med results?
"RTN","GMRCGUIU",137,0)
 ; GMRCIEN - ien from file 123
"RTN","GMRCGUIU",138,0)
 N PROC
"RTN","GMRCGUIU",139,0)
 I '$D(^GMR(123,GMRCIEN,0)) Q 0  ;bad record
"RTN","GMRCGUIU",140,0)
 S PROC=+$P(^GMR(123,GMRCIEN,0),U,8) I 'PROC Q 0  ;no procedure
"RTN","GMRCGUIU",141,0)
 I +$G(^GMR(123,GMRCIEN,1)) Q 0  ;med rslts not allowed on CP
"RTN","GMRCGUIU",142,0)
 I '+$P(^GMR(123.3,PROC,0),U,5) Q 0  ;proc not set up
"RTN","GMRCGUIU",143,0)
 Q 1
"RTN","GMRCHL7")
0^1^B31393339
"RTN","GMRCHL7",1,0)
GMRCHL7 ;SLC/DCM,JFR - CONSULTS-->CPRS HL7 MESSAGING ;07/07/09  09:03
"RTN","GMRCHL7",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,19,29,66**;DEC 27, 1997;Build 30
"RTN","GMRCHL7",3,0)
 ;
"RTN","GMRCHL7",4,0)
 ; This routine invokes IA #872(File 101 ^ORD), #2638(^ORD(100.01,)), #2698(^ORD(101.42,), #10103(XLFDT), #10101(XQOR)
"RTN","GMRCHL7",5,0)
 ;
"RTN","GMRCHL7",6,0)
 ;;Format the HL-7 Message header
"RTN","GMRCHL7",7,0)
 Q
"RTN","GMRCHL7",8,0)
INIT S HLQ=""""""
"RTN","GMRCHL7",9,0)
 S SEP1="|",SEP2="^",SEP3="~",SEP4="\",SEP5="&"
"RTN","GMRCHL7",10,0)
 Q
"RTN","GMRCHL7",11,0)
MSH(X) ;Format MSH segment of HL-7 message.
"RTN","GMRCHL7",12,0)
 ;FROM=GMRC CONSULTS - the sending application
"RTN","GMRCHL7",13,0)
 N X
"RTN","GMRCHL7",14,0)
 I '$D(HLQ) D INIT
"RTN","GMRCHL7",15,0)
 S X="MSH|^~\&|CONSULTS|"_$S(+$G(DUZ(2)):DUZ(2),1:$$SITE^VASITE())_"|||||ORM"
"RTN","GMRCHL7",16,0)
 Q X
"RTN","GMRCHL7",17,0)
PID(GMRCIEN) ;Format the HL-7 PID segment
"RTN","GMRCHL7",18,0)
 ;GMRCIEN=IEN of consult from File 123
"RTN","GMRCHL7",19,0)
 N X
"RTN","GMRCHL7",20,0)
 S GMRCDPT=$P(^GMR(123,GMRCIEN,0),"^",2)
"RTN","GMRCHL7",21,0)
 S GMRCPTN=$P($G(^DPT(GMRCDPT,0)),"^")
"RTN","GMRCHL7",22,0)
 S X="PID|||"_+GMRCDPT_"||"_GMRCPTN
"RTN","GMRCHL7",23,0)
 K GMRCDPT,GMRCPTN
"RTN","GMRCHL7",24,0)
 Q X
"RTN","GMRCHL7",25,0)
PV1(GMRCIEN,RMBED,VISIT) ;Format the HL-7 PV1 segment
"RTN","GMRCHL7",26,0)
 N GMRCSTS,SEP1,X,Y
"RTN","GMRCHL7",27,0)
 S HOSPLOC=$P(^GMR(123,GMRCIEN,0),"^",4)
"RTN","GMRCHL7",28,0)
 S VISIT=$$HL7DT(VISIT),GMRCSTS=$S($P(^GMR(123,GMRCIEN,0),"^",18)]"":$P(^(0),"^",18),HOSPLOC]"":"I",1:"O")
"RTN","GMRCHL7",29,0)
 S X="PV1"_"||"_GMRCSTS_"|"_$S(HOSPLOC]"":HOSPLOC,1:"")_"^"_$S(RMBED]"":RMBED,1:"")_"|"_$S(VISIT]"":VISIT,1:"")
"RTN","GMRCHL7",30,0)
 K Y,HOSPLOC,VISIT,GMRCSTS
"RTN","GMRCHL7",31,0)
 Q X
"RTN","GMRCHL7",32,0)
NTE(NTE,ND) ;Format the HL-7 NTE segment
"RTN","GMRCHL7",33,0)
 Q:'$D(NTE)  Q:'$O(NTE(0))
"RTN","GMRCHL7",34,0)
 S GMRCND=1,GMRCND1=0 D
"RTN","GMRCHL7",35,0)
 .S GMRCND1=$O(NTE(GMRCND1)),@(MSG_"("_ND_")")=NTE(GMRCND1)
"RTN","GMRCHL7",36,0)
 .F  S GMRCND1=$O(NTE(GMRCND1)) Q:GMRCND1=""  I NTE(GMRCND1)]"" S @(MSG_"("_ND_","_GMRCND_")")=NTE(GMRCND1),GMRCND=GMRCND+1
"RTN","GMRCHL7",37,0)
 .Q
"RTN","GMRCHL7",38,0)
 Q
"RTN","GMRCHL7",39,0)
EN(PATID,GMRCIEN,GMRCRTYP,RMBED,ORCTRL,GMRCPLCR,VISIT,GMRCOM,GRPUPD,ACTDT) ;;Main entry point
"RTN","GMRCHL7",40,0)
 ;PATID=DFN - Patients internal entry number from ^DPT(
"RTN","GMRCHL7",41,0)
 ;GMRCIEN=IEN of consult, from File 123
"RTN","GMRCHL7",42,0)
 ;RMBED=Hospital Room/Bed if patient is hospitalized
"RTN","GMRCHL7",43,0)
 ;ORCTRL=Code from HL-7 table 119 (Appendix A) Order Control Codes
"RTN","GMRCHL7",44,0)
 ;VISIT=Visit as a DATE/TIME in Fileman Format.
"RTN","GMRCHL7",45,0)
 ;GMRCPROV=Provider - IEN from file 200
"RTN","GMRCHL7",46,0)
 ;GMRCRTYP=consult type: GMRC REQUEST or GMRC CONSULT
"RTN","GMRCHL7",47,0)
 ;GMRCPLCR=who is entering the order ; usually passed as DUZ for new order, "" for existing order
"RTN","GMRCHL7",48,0)
 ;GMRCOM=comment array flag: 1 if there is comment array, 0 otherwise
"RTN","GMRCHL7",49,0)
 ;GMRCOM(0)=DA of where comment is located: ^GMR(123,IEN,40,DA,
"RTN","GMRCHL7",50,0)
 ;GRPUPD = group update of consults - sends nature as MAINTENANCE
"RTN","GMRCHL7",51,0)
 ;ACTDT = date/time of activity if sent
"RTN","GMRCHL7",52,0)
 Q:'$L(ORCTRL)
"RTN","GMRCHL7",53,0)
 K GMRCMSS
"RTN","GMRCHL7",54,0)
 N MSG,MSH,PID,PV1,ORC,NTE,OBR,OBX,ZSV,GMRCA,GMRCURGI,GMRCPLI
"RTN","GMRCHL7",55,0)
 N GMRCPR,GMRCSS,GMRCTYPE,ORCPLCR
"RTN","GMRCHL7",56,0)
 S MSH="",MSH=$$MSH(MSH)
"RTN","GMRCHL7",57,0)
 S PID=$$PID(GMRCIEN)
"RTN","GMRCHL7",58,0)
 I ORCTRL'="Z@" S PV1=$$PV1(GMRCIEN,RMBED,VISIT)
"RTN","GMRCHL7",59,0)
 D ORC(GMRCIEN,ORCTRL,GMRCPLCR,$G(GRPUPD),$G(ACTDT))
"RTN","GMRCHL7",60,0)
 S ORCTRL=$P(ORCTRL,U)
"RTN","GMRCHL7",61,0)
 I ORCTRL="Z@" S ORC=$P(ORC,SEP1,1,4)
"RTN","GMRCHL7",62,0)
 D:ORCTRL'="Z@" OBR^GMRCHL72(GMRCIEN,$G(GMRCAUTH),$G(ACTDT))
"RTN","GMRCHL7",63,0)
 ;GMRCAUTH=principle results interpreter
"RTN","GMRCHL7",64,0)
 D ZSV(GMRCIEN)
"RTN","GMRCHL7",65,0)
 I $S(ORCTRL="SN":1,ORCTRL="RE":1,ORCTRL="XX":1,1:0) D OBX^GMRCHL72(GMRCIEN)
"RTN","GMRCHL7",66,0)
 I $S(ORCTRL="OC":1,ORCTRL="OD":1,ORCTRL="XX":1,ORCTRL="SC":1,1:0),$G(GMRCOM(0)) D NTE^GMRCHL72(GMRCIEN,.GMRCOM,ORCTRL)
"RTN","GMRCHL7",67,0)
 D BLD(MSH,PID,$G(PV1),$G(ORC),$G(OBR),$G(ZSV),.OBX,.NTE,ORCTRL)
"RTN","GMRCHL7",68,0)
 ;M GMRCMSS=GMRCMSG ;HL-7 message debugging aid - remove from final version
"RTN","GMRCHL7",69,0)
 D MSG^XQOR("GMRC EVSEND OR",.GMRCMSG)
"RTN","GMRCHL7",70,0)
 K GMRCND,GMRCND1,GMRCMSG,GMRCNOD,GMRCORFN,GMRCPLI,GMRCPRI,HL7DT,HLQ,J,ND,ND1,ND2,NOTIFY,OBXND,OBXNO,ORCACT,ORCDT,ORURG,SEP1,SEP2,SEP3,SEP4,SEP5
"RTN","GMRCHL7",71,0)
 Q
"RTN","GMRCHL7",72,0)
BLD(MSH,PID,PV1,ORC,OBR,ZSV,OBX,NTE,CTRLCD) ;Build the HL-7 message global to pass to OR
"RTN","GMRCHL7",73,0)
 S MSG="GMRCMSG",ND=1
"RTN","GMRCHL7",74,0)
 K @(MSG)
"RTN","GMRCHL7",75,0)
 F J="MSH","PID","PV1" I $G(@J)]"" S @(MSG_"("_ND_")")=@J,ND=ND+1
"RTN","GMRCHL7",76,0)
 I ORC]"" S @(MSG_"("_ND_")")=ORC,ND=ND+1
"RTN","GMRCHL7",77,0)
 I $D(NTE),$O(NTE(0)) D NTE(.NTE,ND) S ND=ND+1
"RTN","GMRCHL7",78,0)
 I OBR]"" S @(MSG_"("_ND_")")=OBR,ND=ND+1
"RTN","GMRCHL7",79,0)
 I $L($G(ZSV)) S @(MSG_"("_ND_")")=ZSV,ND=ND+1
"RTN","GMRCHL7",80,0)
 I $O(OBX("")) S OBXND=0 D
"RTN","GMRCHL7",81,0)
 .F  S OBXND=$O(OBX(OBXND)) Q:OBXND=""  D
"RTN","GMRCHL7",82,0)
 .. S @(MSG_"("_ND_")")=OBX(OBXND)
"RTN","GMRCHL7",83,0)
 .. S GMRCND1=0 F  S GMRCND1=$O(OBX(OBXND,GMRCND1)) Q:GMRCND1=""  D
"RTN","GMRCHL7",84,0)
 ... S @(MSG_"("_ND_","_GMRCND1_")")=OBX(OBXND,GMRCND1)
"RTN","GMRCHL7",85,0)
        .. S ND=ND+1
"RTN","GMRCHL7",86,0)
 .Q
"RTN","GMRCHL7",87,0)
 ;I CTRLCD'="XX",$D(NTE),$O(NTE(0)) D NTE(.NTE,ND) S ND=ND+1
"RTN","GMRCHL7",88,0)
 Q
"RTN","GMRCHL7",89,0)
HL7DT(DATE) ;Convert Fileman Date to HL-7 Date
"RTN","GMRCHL7",90,0)
 I 'DATE Q ""
"RTN","GMRCHL7",91,0)
 Q $$FMTHL7^XLFDT(DATE) ; use standard function
"RTN","GMRCHL7",92,0)
 N X
"RTN","GMRCHL7",93,0)
 S X="" I DATE S X=17000000+$P(DATE,".",1)_$P(DATE,".",2)
"RTN","GMRCHL7",94,0)
 Q X
"RTN","GMRCHL7",95,0)
FMDATE(DATE) ;Convert HL-7 formatted date to a Fileman formatted date
"RTN","GMRCHL7",96,0)
 I 'DATE Q ""
"RTN","GMRCHL7",97,0)
 Q $$HL7TFM^XLFDT(DATE) ; use standard function
"RTN","GMRCHL7",98,0)
 N X
"RTN","GMRCHL7",99,0)
ORC(GMRCIEN,GMRCTRL,ORCPLCR,MAINT,GMRCDT) ;Build ORC segment of HL-7 msg
"RTN","GMRCHL7",100,0)
 ;GMRCTRL=Order Control Code (table 119)
"RTN","GMRCHL7",101,0)
 ;GMRCIEN=File 123 IEN
"RTN","GMRCHL7",102,0)
 ;ORPLCR=GMRCPLCR - the person entering the order
"RTN","GMRCHL7",103,0)
 ;MAINT=1 - group update of requests
"RTN","GMRCHL7",104,0)
 ;GMRCDT=date/time of activity, GMRCERDT=earliest appropriate date wat/66
"RTN","GMRCHL7",105,0)
 N GMRCURG,ORCACT,ORCDT,ORCPRV,ORCDT,ORIEN,ORCSTS,STS,ORCNATR,QUANT,REAS,GMRCERDT
"RTN","GMRCHL7",106,0)
 S REAS=$P(GMRCTRL,U,2),GMRCTRL=$P(GMRCTRL,U)
"RTN","GMRCHL7",107,0)
 S ORCDT=$P(^GMR(123,GMRCIEN,0),"^",7),ORCPRV=$P(^GMR(123,GMRCIEN,0),"^",14),ORURG=$P(^(0),"^",9),ORURG=$S(ORURG]"":$P(^ORD(101,ORURG,0),"^",1),1:"") S:ORURG]"" ORURG=$P(ORURG," - ",2)
"RTN","GMRCHL7",108,0)
 S ORURG=$S(ORURG="EMERGENCY":"STAT",ORURG="NOW":"STAT",ORURG="OUTPATIENT":"ROUTINE",1:ORURG)
"RTN","GMRCHL7",109,0)
 S:ORURG="" GMRCURG="" I ORURG]"" S GMRCURG=$O(^ORD(101.42,"B",ORURG,0)),GMRCURG=$S(+GMRCURG:$P(^ORD(101.42,GMRCURG,0),"^",2),1:"")
"RTN","GMRCHL7",110,0)
 S GMRCERDT=$P(^GMR(123,GMRCIEN,0),"^",24),GMRCERDT=$$HL7DT($G(GMRCERDT)) ;WAT/66
"RTN","GMRCHL7",111,0)
 S ORCDT=$$HL7DT(ORCDT)
"RTN","GMRCHL7",112,0)
 I '$G(GMRCDT) S GMRCDT=$$NOW^XLFDT
"RTN","GMRCHL7",113,0)
 S STS=$P(^GMR(123,GMRCIEN,0),"^",12)
"RTN","GMRCHL7",114,0)
 S ORCACT=$P($G(^ORD(100.01,+STS,0)),U,1) S:'$L(ORCACT) ORCACT="NO STATUS"
"RTN","GMRCHL7",115,0)
 S ORIEN=$P(^GMR(123,GMRCIEN,0),"^",3)
"RTN","GMRCHL7",116,0)
 S ORCSTS=$S(STS=1:"DC",STS=2:"CM",STS=5:"IP",STS=6:"SC",STS=9:"A",STS=12:"RP",STS=13:"CA",STS=8:"ZC",1:"IP")
"RTN","GMRCHL7",117,0)
 S ORCNATR=""
"RTN","GMRCHL7",118,0)
 I GMRCTRL="XX" S ORCNATR="S^SERVICE CORRECTION^99ORN^^"_REAS_"^"
"RTN","GMRCHL7",119,0)
 I $G(MAINT) S ORCNATR="M^MAINTENANCE^99ORN^^^"
"RTN","GMRCHL7",120,0)
 S QUANT=$S(GMRCURG]"":"^^^"_$G(GMRCERDT)_"^^"_GMRCURG,1:"") ;wat/66
"RTN","GMRCHL7",121,0)
 S GMRCDT=$$HL7DT(GMRCDT)
"RTN","GMRCHL7",122,0)
 S ORC="ORC|"_GMRCTRL_"|"_$S(ORIEN]"":ORIEN_";1^OR",1:"")_"|"
"RTN","GMRCHL7",123,0)
 S ORC=ORC_GMRCIEN_";GMRC^"_"GMRC"_"||"_ORCSTS_"||"_QUANT_"||"
"RTN","GMRCHL7",124,0)
 S ORC=ORC_GMRCDT_"|"_ORCPLCR_"||"_ORCPRV_"|||"_ORCDT_"|"_ORCNATR
"RTN","GMRCHL7",125,0)
 Q
"RTN","GMRCHL7",126,0)
ZSV(GMRCO) ;build ZSV segment for at least forward
"RTN","GMRCHL7",127,0)
 N SERV,SERVNM,CTYPE
"RTN","GMRCHL7",128,0)
 S SERV=$P($G(^GMR(123,GMRCO,0)),U,5)
"RTN","GMRCHL7",129,0)
 I 'SERV Q
"RTN","GMRCHL7",130,0)
 S SERVNM=$P($G(^GMR(123.5,SERV,0)),U)
"RTN","GMRCHL7",131,0)
 S CTYPE=$G(^GMR(123,GMRCO,1.11))
"RTN","GMRCHL7",132,0)
 I CTYPE=SERVNM S CTYPE=""
"RTN","GMRCHL7",133,0)
 I $P(^GMR(123,GMRCO,0),U,8) S CTYPE=""
"RTN","GMRCHL7",134,0)
 S ZSV="ZSV|^^^"_SERV_U_SERVNM_"^99CON|"_CTYPE
"RTN","GMRCHL7",135,0)
 Q
"RTN","GMRCHL7A")
0^2^B29763566
"RTN","GMRCHL7A",1,0)
GMRCHL7A ;SLC/DCM,MA - Receive HL-7 Message from OERR ;10/28/10  09:43
"RTN","GMRCHL7A",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,21,22,33,68,66**;DEC 27, 1997;Build 30
"RTN","GMRCHL7A",3,0)
 ;
"RTN","GMRCHL7A",4,0)
 ; This routine invokes IA #872(FILE 101 ^ORD(100)), #2053(DIE)
"RTN","GMRCHL7A",5,0)
 ;
"RTN","GMRCHL7A",6,0)
URG(X) ;Return Urgency give Z-code from HL-7 segment; see ORC+9
"RTN","GMRCHL7A",7,0)
 S X=$S(X="S":"STAT",X="R":"ROUTINE",X="ZT":"TODAY",X="Z24":"WITHIN 24 HOURS",X="Z48":"WITHIN 48 HOURS",X="Z72":"WITHIN 72 HOURS",X="ZW":"WITHIN 1 WEEK",X="ZM":"WITHIN 1 MONTH",X="ZNA":"NEXT AVAILABLE",1:X)
"RTN","GMRCHL7A",8,0)
 I $E(X,1)="Z" S X=$S(X="ZT":"TODAY",X="ZE":"EMERGENCY",1:"")
"RTN","GMRCHL7A",9,0)
 Q X
"RTN","GMRCHL7A",10,0)
 ;
"RTN","GMRCHL7A",11,0)
ORC(GMRCORC) ;Get fields from ORC segment and set into GMRC variables
"RTN","GMRCHL7A",12,0)
 ;GMRCTRLC=ORC control code from HL7 Table 119
"RTN","GMRCHL7A",13,0)
 ;GMRCURGI=priority/urgency     GMRCPLCR=who entered the order
"RTN","GMRCHL7A",14,0)
 ;GMRCORNP=provider             GMRCNATO=nature of order
"RTN","GMRCHL7A",15,0)
 ;GMRCAD=date of request        GMRCOCR=order request reason
"RTN","GMRCHL7A",16,0)
 ;GMRCORFN=oe/rr file number    GMRCO=file 123 IEN - if not a new order
"RTN","GMRCHL7A",17,0)
 ;GMRCS38=order status - taken from Table 38, HL7 standard
"RTN","GMRCHL7A",18,0)
 ;GMRCERDT=earliest date desired
"RTN","GMRCHL7A",19,0)
 S GMRCTRLC=$P(GMRCORC,SEP1,2),GMRCORFN=$P(GMRCORC,SEP1,3),GMRCORFN=$P($P(GMRCORFN,SEP2,1),";",1),GMRCAPP=$P($P(GMRCORC,SEP1,3),SEP2,2)
"RTN","GMRCHL7A",20,0)
 S GMRCS38=$P(GMRCORC,SEP1,6),GMRCURGI=$P($P(GMRCORC,SEP1,8),SEP2,6),GMRCPLCR=$P(GMRCORC,SEP1,11),GMRCORNP=$P(GMRCORC,SEP1,13)
"RTN","GMRCHL7A",21,0)
 I $L(GMRCURGI) S GMRCURGI="GMRCURGENCY - "_$$URG(GMRCURGI),GMRCURGI=$O(^ORD(101,"B",GMRCURGI,0))
"RTN","GMRCHL7A",22,0)
 S GMRCERDT=$P($P(GMRCORC,SEP1,8),SEP2,4),GMRCERDT=$$FMDATE^GMRCHL7($G(GMRCERDT)) ;WAT/66
"RTN","GMRCHL7A",23,0)
 S GMRCO=+$P($P(GMRCORC,SEP1,4),SEP2,1)
"RTN","GMRCHL7A",24,0)
 S GMRCODT=$P(GMRCORC,SEP1,16),GMRCAD=$$FMDATE^GMRCHL7(GMRCODT)
"RTN","GMRCHL7A",25,0)
 S GMRCOCR=$P(GMRCORC,SEP1,17),GMRCNATO=$P(GMRCOCR,SEP2,5)
"RTN","GMRCHL7A",26,0)
 Q
"RTN","GMRCHL7A",27,0)
OBR(GMRCOBR) ;Get fields from OBR segment and set into GMRC variables
"RTN","GMRCHL7A",28,0)
 ;GMRCTYPE=GMRC consult or GMRC request  GMRCSS=To Service
"RTN","GMRCHL7A",29,0)
 ;GMRCPLI=place of consultation          GMRCODT=observation date/time
"RTN","GMRCHL7A",30,0)
 ;GMRCATN=person to alert (attention)    GMRCSTDT=status change date/time
"RTN","GMRCHL7A",31,0)
 ;GMRCS123=results status (table 123)    GMRCINTR=results interpreter
"RTN","GMRCHL7A",32,0)
 ;GMRCPRI=procedure from file ^ORD(101,
"RTN","GMRCHL7A",33,0)
 ;GMRCXMF=foreign consult service
"RTN","GMRCHL7A",34,0)
 ;        a flag that tells the HL7 routine that
"RTN","GMRCHL7A",35,0)
 ;        consults does not need to return CPRS a file
"RTN","GMRCHL7A",36,0)
 ;        IEN for file 123. See routine ^GMRCXMF
"RTN","GMRCHL7A",37,0)
 S GMRCPR=$P($P(GMRCOBR,SEP1,5),SEP2,6)
"RTN","GMRCHL7A",38,0)
 S GMRCTYPE=$S(GMRCPR="99PRC":"P",1:"C")
"RTN","GMRCHL7A",39,0)
 S GMRCPRI="",GMRCSS=""
"RTN","GMRCHL7A",40,0)
 I GMRCPR="99PRC" D
"RTN","GMRCHL7A",41,0)
 . S GMRCPRI=$P($P(GMRCOBR,SEP1,5),SEP2,4)
"RTN","GMRCHL7A",42,0)
 . S GMRCPRI=$S(+GMRCPRI:GMRCPRI_";GMR(123.3,",1:"")
"RTN","GMRCHL7A",43,0)
 . Q
"RTN","GMRCHL7A",44,0)
 ;
"RTN","GMRCHL7A",45,0)
 S GMRCOTXT=$P($P(GMRCOBR,SEP1,5),SEP2,5) ;consult type or service name
"RTN","GMRCHL7A",46,0)
 S GMRCODT=$P(GMRCOBR,SEP1,7) I GMRCODT]"" S GMRCODT=$$FMDATE^GMRCHL7(GMRCODT)
"RTN","GMRCHL7A",47,0)
 S GMRCPLI=$P(GMRCOBR,SEP1,19) I GMRCPLI]"" S GMRCPLI="GMRCPLACE - "_$S(GMRCPLI="OC":"ON CALL",GMRCPLI="B":"BEDSIDE",GMRCPLI="E":"EMERGENCY ROOM",1:GMRCPLI),GMRCPLI=$O(^ORD(101,"B",GMRCPLI,0))
"RTN","GMRCHL7A",48,0)
 S GMRCATN=$P(GMRCOBR,SEP1,20),GMRCSTDT=$P(GMRCOBR,SEP1,23),GMRCSTDT=$$FMDATE^GMRCHL7(GMRCSTDT)
"RTN","GMRCHL7A",49,0)
 S GMRCS123=$P(GMRCOBR,SEP1,26),GMRCINTR=$P(GMRCOBR,SEP1,33)
"RTN","GMRCHL7A",50,0)
 Q
"RTN","GMRCHL7A",51,0)
ZSV(GMRCZSV) ;Get service from ZSV segment and set into GMRCSS
"RTN","GMRCHL7A",52,0)
 S GMRCZSS=$P($P(GMRCZSV,SEP1,2),SEP2,4)
"RTN","GMRCHL7A",53,0)
 I +$G(GMRCZSS) S GMRCSS=+$G(GMRCZSS) ;Set the service if ZSV provided
"RTN","GMRCHL7A",54,0)
 I $L($P(GMRCZSV,"|",3)) S GMRCOTXT=$P(GMRCZSV,"|",3) ;consult type
"RTN","GMRCHL7A",55,0)
 Q
"RTN","GMRCHL7A",56,0)
OBX(GMRCOBX) ;Get fields from OBX segment and set into GMRC variables
"RTN","GMRCHL7A",57,0)
 ;GMRCVTYP=Value type from table 123 - i.e. TX(text), ST(string data),etc.
"RTN","GMRCHL7A",58,0)
 ;GMRCOID=observation id identifying value in seg. 5
"RTN","GMRCHL7A",59,0)
 ;GMRCVAL=observation value coded by segment 3
"RTN","GMRCHL7A",60,0)
 ;GMRCPRDG=provisional diagnosis
"RTN","GMRCHL7A",61,0)
 ;    free text or code^free text^I9C
"RTN","GMRCHL7A",62,0)
 S GMRCMSG=MSG(GMRCOBX)
"RTN","GMRCHL7A",63,0)
 S GMRCVTYP=$P(GMRCMSG,SEP1,3),GMRCOID=$P($P(GMRCMSG,SEP1,4),SEP2,2),GMRCVAL=$P(GMRCOID,SEP2,3)
"RTN","GMRCHL7A",64,0)
 I GMRCOID="REASON FOR REQUEST" D
"RTN","GMRCHL7A",65,0)
 .S GMRCRFQ(1)=$P(GMRCMSG,SEP1,6)
"RTN","GMRCHL7A",66,0)
 .S LN=0 F  S LN=$O(MSG(GMRCOBX,LN)) Q:LN=""  S GMRCRFQ(LN+1)=MSG(GMRCOBX,LN)
"RTN","GMRCHL7A",67,0)
 .Q
"RTN","GMRCHL7A",68,0)
 I GMRCOID="PROVISIONAL DIAGNOSIS" D  Q
"RTN","GMRCHL7A",69,0)
 . I GMRCVTYP="TX" D  Q
"RTN","GMRCHL7A",70,0)
 .. S GMRCPRDG=$P(GMRCMSG,SEP1,6)
"RTN","GMRCHL7A",71,0)
 .. S GMRCPRDG=$TR(GMRCPRDG,$C(9,10,13)," ") Q
"RTN","GMRCHL7A",72,0)
 . I GMRCVTYP="CE" D  Q
"RTN","GMRCHL7A",73,0)
 .. N PRDXSEG S PRDXSEG=$P(GMRCMSG,SEP1,6)
"RTN","GMRCHL7A",74,0)
 .. S GMRCPRDG=$TR($P(PRDXSEG,"^",2),$C(9,10,13),"")_"("_$P(PRDXSEG,"^")_")"
"RTN","GMRCHL7A",75,0)
 .. S GMRCPRCD=$P(PRDXSEG,"^")
"RTN","GMRCHL7A",76,0)
 I GMRCOID["COMMENT" D
"RTN","GMRCHL7A",77,0)
 .S GMRCCMT(1)=$P(GMRCMSG,SEP1,6)
"RTN","GMRCHL7A",78,0)
 .S LN=0 F  S LN=$O(MSG(GMRCOBX,LN)) Q:LN=""  S GMRCCMT(LN+1)=MSG(GMRCOBX,LN)
"RTN","GMRCHL7A",79,0)
 .Q
"RTN","GMRCHL7A",80,0)
 K LN
"RTN","GMRCHL7A",81,0)
 Q
"RTN","GMRCHL7A",82,0)
EN(MSG) ;Entry point to routine
"RTN","GMRCHL7A",83,0)
 ;MSG = local array which contains the HL-7 segments
"RTN","GMRCHL7A",84,0)
 ;GMRCSEND=sending application   GMRCFAC=sending facility
"RTN","GMRCHL7A",85,0)
 ;GMRCMTP=message type
"RTN","GMRCHL7A",86,0)
 N DFN,GMRCACT,GMRCADD,GMRCFAC,GMRCMTP,GMRCPNM,GMRCO,GMRCOCR,GMRCORNP
"RTN","GMRCHL7A",87,0)
 N GMRCORFN,GMRCPLCR,GMRCRB,GMRCSEND,GMRCSTS,GMRCTRLC,GMRCWARD,ORIFN
"RTN","GMRCHL7A",88,0)
 N GMRCTRLC,GMRCAD,ORC,GMRCSBR,GMRCZSS,GMRCSS,GMRCOTXT,GMRCPRCD
"RTN","GMRCHL7A",89,0)
 N GMRCREJ,GMRCRECV,GMRCERDT
"RTN","GMRCHL7A",90,0)
 S GMRCMSG="",GMRCNOD=0 F  S GMRCNOD=$O(MSG(GMRCNOD)) Q:GMRCNOD=""  S GMRCMSG=MSG(GMRCNOD) I $E(GMRCMSG,1,3)="MSH" D INIT^GMRCHL7U(GMRCMSG) D  Q
"RTN","GMRCHL7A",91,0)
 .S GMRCSEND=$P(GMRCMSG,SEP1,3),GMRCFAC=$P(GMRCMSG,SEP1,4)
"RTN","GMRCHL7A",92,0)
 .S GMRCMTP=$P(GMRCMSG,SEP1,9),GMRCRECV=$P(GMRCMSG,SEP1,5)
"RTN","GMRCHL7A",93,0)
 .Q
"RTN","GMRCHL7A",94,0)
 I $G(GMRCRECV)'="CONSULTS" Q  ;not intended for Consults
"RTN","GMRCHL7A",95,0)
 S GMRCMSG="",GMRCNOD=0
"RTN","GMRCHL7A",96,0)
 F  S GMRCNOD=$O(MSG(GMRCNOD)) Q:GMRCNOD=""  S GMRCMSG=MSG(GMRCNOD) D
"RTN","GMRCHL7A",97,0)
 .I $E(GMRCMSG,1,3)="PID" D PID^GMRCHL7U(GMRCMSG) Q
"RTN","GMRCHL7A",98,0)
 .I $E(GMRCMSG,1,3)="PV1" D PV1^GMRCHL7U(GMRCMSG) Q
"RTN","GMRCHL7A",99,0)
 .I $E(GMRCMSG,1,3)="ORC" D ORC(GMRCMSG) Q
"RTN","GMRCHL7A",100,0)
 .I $E(GMRCMSG,1,3)="OBR" D OBR(GMRCMSG) Q
"RTN","GMRCHL7A",101,0)
 .I $E(GMRCMSG,1,3)="ZSV" D ZSV(GMRCMSG) Q
"RTN","GMRCHL7A",102,0)
 .I $E(GMRCMSG,1,3)="OBX" D OBX(GMRCNOD) Q
"RTN","GMRCHL7A",103,0)
 .I $E(GMRCMSG,1,3)="NTE" D NTE^GMRCHL7U(.MSG,GMRCNOD,GMRCO,GMRCTRLC) Q
"RTN","GMRCHL7A",104,0)
 .I $E(GMRCMSG,1,3)="ZXX" S GMRCOFN=+$P(GMRCMSG,SEP1,2) K MSG(GMRCNOD) Q
"RTN","GMRCHL7A",105,0)
 .Q
"RTN","GMRCHL7A",106,0)
 ;Note, ZXX is not used yet; planned for future sharing consults with foreign facilities.
"RTN","GMRCHL7A",107,0)
 I '$D(GMRCTRLC) D EXIT^GMRCHL7U Q
"RTN","GMRCHL7A",108,0)
 I GMRCTRLC="Z@" D CPRSPURG^GMRCPURG(+GMRCO),EXIT^GMRCHL7U Q
"RTN","GMRCHL7A",109,0)
 I GMRCTRLC="NW" D NEW^GMRCHL7B(.GMRCREJ) D
"RTN","GMRCHL7A",110,0)
 . I $G(GMRCO) D RETURN^GMRCHL7U(GMRCO,GMRCTRLC) Q
"RTN","GMRCHL7A",111,0)
 . D REJECT^GMRCHL7U(.MSG,$G(GMRCREJ))
"RTN","GMRCHL7A",112,0)
 I '$D(GMRCO) D EXIT^GMRCHL7U Q
"RTN","GMRCHL7A",113,0)
 I $S(GMRCTRLC="CA":1,GMRCTRLC="DC":1,1:0) D DC^GMRCHL7B(GMRCO,GMRCTRLC),RETURN^GMRCHL7U(GMRCO,GMRCTRLC)
"RTN","GMRCHL7A",114,0)
 I GMRCTRLC="NA" D RTN(GMRCORFN,GMRCO)
"RTN","GMRCHL7A",115,0)
 I GMRCTRLC="XX" D MODIFY^GMRCHL7B ;Not currently returned by CPRS
"RTN","GMRCHL7A",116,0)
 ; If consults sends an XX, CPRS returns an NA.
"RTN","GMRCHL7A",117,0)
 D EXIT^GMRCHL7U
"RTN","GMRCHL7A",118,0)
 Q
"RTN","GMRCHL7A",119,0)
RTN(GMRCORN,DA) ;Put ^OR(100, ien for order into ^GMR(123,
"RTN","GMRCHL7A",120,0)
 S DIE="^GMR(123,",DR=".03////^S X=GMRCORN"
"RTN","GMRCHL7A",121,0)
 L +^GMR(123,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:5) D ^DIE L -^GMR(123,DA) ;wat/66 add lock timeout
"RTN","GMRCHL7A",122,0)
 K DIE,DR
"RTN","GMRCHL7A",123,0)
 Q
"RTN","GMRCHL7B")
0^3^B26577242
"RTN","GMRCHL7B",1,0)
GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A ;04/29/09  08:53
"RTN","GMRCHL7B",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33,66**;DEC 27, 1997;Build 30
"RTN","GMRCHL7B",3,0)
 ;
"RTN","GMRCHL7B",4,0)
 ; This routine invokes IA #3991(ICDAPIU), #2053(DIE), #10006(DIC), #2056(GET1^DIQ)
"RTN","GMRCHL7B",5,0)
 ;
"RTN","GMRCHL7B",6,0)
NEW(MESSAGE) ;Add new order
"RTN","GMRCHL7B",7,0)
 ;GMRCO=^GMR(123,IFN, the new file number in file ^GMR(123,
"RTN","GMRCHL7B",8,0)
 ;GMRCORFN=OE/RR file number       GMRCWARD=ward patient is on
"RTN","GMRCHL7B",9,0)
 ;GMRCSS=service consult sent to   GMRCAD=date/time of request
"RTN","GMRCHL7B",10,0)
 ;GMRCPRI=procedure/request        GMRCURGI=urgency
"RTN","GMRCHL7B",11,0)
 ;GMRCERDT=earliest desired date
"RTN","GMRCHL7B",12,0)
 ;GMRCATN=attention                GMRCSTS=OE/RR order status
"RTN","GMRCHL7B",13,0)
 ;GMRCORNP=patient's provider      GMRCTYPE=request type (request or consult)
"RTN","GMRCHL7B",14,0)
 ;GMRCSBR=service rendered on what basis (Inpatient, or Outpatient)
"RTN","GMRCHL7B",15,0)
 ;GMRCRFQ=reason for request array - word processing fields
"RTN","GMRCHL7B",16,0)
 ;GMRCOTXT=order display text from dialog or orderable item
"RTN","GMRCHL7B",17,0)
 ;GMRCPRDG=provisional DX
"RTN","GMRCHL7B",18,0)
 ;GMRCPRCD=provisional DX code
"RTN","GMRCHL7B",19,0)
 ;
"RTN","GMRCHL7B",20,0)
 ; Output:
"RTN","GMRCHL7B",21,0)
 ;    MESSAGE = rejection message if problems encountered while filing
"RTN","GMRCHL7B",22,0)
 ;
"RTN","GMRCHL7B",23,0)
 ;    check for inactive ICD-9 code in Prov. DX
"RTN","GMRCHL7B",24,0)
 I $L($G(GMRCPRCD)) D  I $D(MESSAGE) Q  ; rejected due to inactive code
"RTN","GMRCHL7B",25,0)
 . I +$$STATCHK^ICDAPIU(GMRCPRCD,DT) Q  ;code is OK
"RTN","GMRCHL7B",26,0)
 . S MESSAGE="Provisional DX code is inactive. Unable to file request."
"RTN","GMRCHL7B",27,0)
 ;
"RTN","GMRCHL7B",28,0)
 N DIC,DLAYGO,X,Y,DR,DIE,GMRCADUZ,GMRCCP
"RTN","GMRCHL7B",29,0)
 S DIC="^GMR(123,",DIC(0)="L",X="""N""",DLAYGO=123 D ^DIC K DLAYGO Q:Y<1
"RTN","GMRCHL7B",30,0)
 ; Patch #21 changed GMRCA=1 to GMRCA=2
"RTN","GMRCHL7B",31,0)
 S (DA,GMRCO)=+Y,GMRCSTS=5,GMRCA=2,DIE=DIC
"RTN","GMRCHL7B",32,0)
 L +^GMR(123,GMRCO)
"RTN","GMRCHL7B",33,0)
 S DR=".02////^S X=DFN;.03////^S X=GMRCORFN;.04////^S X=GMRCWARD;.05////^S X=GMRCFAC;.06////^S X=$G(GMRCOFN);1////^S X=GMRCSS;2////^S X=$G(GMRCWARD);3////^S X=GMRCAD;4////^S X=GMRCPRI;5////^S X=GMRCURGI;7////^S X=$G(GMRCATN)"
"RTN","GMRCHL7B",34,0)
 D ^DIE
"RTN","GMRCHL7B",35,0)
 I GMRCOTXT=$$GET1^DIQ(123.5,+GMRCSS,.01) S GMRCOTXT=""
"RTN","GMRCHL7B",36,0)
 ;Added new field .1 to DR on 7/11/98 to save the order text
"RTN","GMRCHL7B",37,0)
 S DR="6////^S X=GMRCPLI;8////^S X=GMRCSTS;9////^S X=GMRCA;10////^S X=GMRCORNP;13////^S X=GMRCTYPE;14////^S X=$G(GMRCSBR);17////^S X=$G(GMRCERDT);30////^S X=$G(GMRCPRDG);.1////^S X=$G(GMRCOTXT)" ;wat/66
"RTN","GMRCHL7B",38,0)
 I $D(GMRCPRCD) S DR=DR_";30.1///^S X=GMRCPRCD"
"RTN","GMRCHL7B",39,0)
 S GMRCCP=$P($G(^GMR(123.3,+GMRCPRI,0)),U,4) I GMRCCP D  ;file CP
"RTN","GMRCHL7B",40,0)
 . S DR=DR_";1.01///^S X=GMRCCP"
"RTN","GMRCHL7B",41,0)
 D  ;check to see if an IFC and add .07 ROUTING FACILITY
"RTN","GMRCHL7B",42,0)
 . I $G(GMRCPRI) D  Q  ;see if procedure is mapped
"RTN","GMRCHL7B",43,0)
 .. I '$D(^GMR(123.3,+GMRCPRI,"IFC")) Q
"RTN","GMRCHL7B",44,0)
 .. N IFC S IFC=$G(^GMR(123.3,+GMRCPRI,"IFC"))
"RTN","GMRCHL7B",45,0)
 .. I '+IFC Q  ; no ifc routing site
"RTN","GMRCHL7B",46,0)
 .. I '$L($P(^GMR(123.3,+GMRCPRI,"IFC"),U,2)) Q  ;no remote proc name
"RTN","GMRCHL7B",47,0)
 .. S DR=DR_";.07////"_+IFC_";.125////P"
"RTN","GMRCHL7B",48,0)
 . I '$G(GMRCPRI) D  Q  ;see if service is mapped
"RTN","GMRCHL7B",49,0)
 .. I '$D(^GMR(123.5,+GMRCSS,"IFC")) Q
"RTN","GMRCHL7B",50,0)
 .. N IFC S IFC=$G(^GMR(123.5,+GMRCSS,"IFC"))
"RTN","GMRCHL7B",51,0)
 .. I '+IFC Q  ; no ifc routing site
"RTN","GMRCHL7B",52,0)
 .. I '$L($P(IFC,U,2)) Q  ;no remote service name
"RTN","GMRCHL7B",53,0)
 .. S DR=DR_";.07////"_+IFC_";.125////P;.131////"_$P(IFC,U,2)
"RTN","GMRCHL7B",54,0)
 . Q
"RTN","GMRCHL7B",55,0)
 D ^DIE
"RTN","GMRCHL7B",56,0)
 I $O(GMRCRFQ(0)) D REASON
"RTN","GMRCHL7B",57,0)
 L -^GMR(123,GMRCO)
"RTN","GMRCHL7B",58,0)
 S GMRCA=1 D AUDIT0^GMRCHL7U
"RTN","GMRCHL7B",59,0)
 I $D(GMRCXMF),$D(GMRCOFN) S $P(^GMR(123,GMRCO,0),"^",21)=GMRCOFN
"RTN","GMRCHL7B",60,0)
 I $D(GMRCACTN) S GMRCADUZ(GMRCACTN)=""
"RTN","GMRCHL7B",61,0)
 D ALERT^GMRCHL7U(DFN,GMRCSS,GMRCPRI,GMRCO,GMRCURGI,"")
"RTN","GMRCHL7B",62,0)
 D PRNT^GMRCUTL1(GMRCSS,GMRCO) ;contains print audit update
"RTN","GMRCHL7B",63,0)
 D EXIT
"RTN","GMRCHL7B",64,0)
 Q
"RTN","GMRCHL7B",65,0)
DC(GMRCO,ACTRL) ;Discontinue request from OERR
"RTN","GMRCHL7B",66,0)
 ;Denied request also gets this action. Deny request updates status to dc
"RTN","GMRCHL7B",67,0)
 ;GMRCO=IEN of record in file ^GMR(123, i.e., ^GMR(123,DA,
"RTN","GMRCHL7B",68,0)
 ;ACTRL=GMRCCTRL=control code defining action -
"RTN","GMRCHL7B",69,0)
 ;         DC control code = action DC for discontinued
"RTN","GMRCHL7B",70,0)
 ;         CA control code = action DY for denied
"RTN","GMRCHL7B",71,0)
 ;Update the last action taken, order status, and processing activity
"RTN","GMRCHL7B",72,0)
 Q:'$L(GMRCO)
"RTN","GMRCHL7B",73,0)
 Q:'$D(^GMR(123,+GMRCO,0))
"RTN","GMRCHL7B",74,0)
 N GMRCACT,GMRCSVC,GMRCDFN,GMRCFL,GMRCADUZ,GMRCRQR,DA
"RTN","GMRCHL7B",75,0)
 S GMRCACT=$O(^GMR(123.1,"D",ACTRL,0))
"RTN","GMRCHL7B",76,0)
 S GMRCSTS=$P(^GMR(123.1,GMRCACT,0),"^",2)
"RTN","GMRCHL7B",77,0)
 S DIE="^GMR(123,",DA=GMRCO
"RTN","GMRCHL7B",78,0)
 S DR="8////^S X=GMRCSTS;9////^S X=GMRCACT" ; upd status + last action
"RTN","GMRCHL7B",79,0)
 D ^DIE
"RTN","GMRCHL7B",80,0)
 D AUDIT0^GMRCHL7U
"RTN","GMRCHL7B",81,0)
 ; send 513 back through service printer if order DC'd
"RTN","GMRCHL7B",82,0)
 I $G(ACTRL)="DC",$$DCPRNT^GMRCUTL1(GMRCO,DUZ) D
"RTN","GMRCHL7B",83,0)
 . D PRNT^GMRCUTL1(+$P(^GMR(123,GMRCO,0),U,5),GMRCO)
"RTN","GMRCHL7B",84,0)
 S GMRCDFN=$P(^GMR(123,+GMRCO,0),"^",2)
"RTN","GMRCHL7B",85,0)
 S GMRCFL=$$DCNOTE^GMRCADC(GMRCO,DUZ),GMRCADUZ=""
"RTN","GMRCHL7B",86,0)
 S GMRCRQR=+$P($G(^GMR(123,+GMRCO,0)),"^",14)
"RTN","GMRCHL7B",87,0)
 I +GMRCRQR,GMRCRQR'=DUZ S GMRCADUZ(GMRCRQR)=""
"RTN","GMRCHL7B",88,0)
 S GMRCSVC=$P($G(^GMR(123,+GMRCO,0)),"^",5)
"RTN","GMRCHL7B",89,0)
 I +GMRCSVC S GMRCSVC=$S($D(^GMR(123.5,GMRCSVC,.1)):^(.1),1:$P(^GMR(123.5,GMRCSVC,0),"^",1))
"RTN","GMRCHL7B",90,0)
 E  S GMRCSVC="Unknown Service: Consult # "_GMRCO
"RTN","GMRCHL7B",91,0)
 S GMRCORTX=$S(ACTRL="DC":"Discontinued",1:"Cancelled")
"RTN","GMRCHL7B",92,0)
 S GMRCORTX=GMRCORTX_" Consult "_$$ORTX^GMRCAU(GMRCO)
"RTN","GMRCHL7B",93,0)
 N NOTYPE S NOTYPE=$S(ACTRL="DC":23,1:30)
"RTN","GMRCHL7B",94,0)
 D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
"RTN","GMRCHL7B",95,0)
 D EXIT
"RTN","GMRCHL7B",96,0)
 Q
"RTN","GMRCHL7B",97,0)
MODIFY ;Change an order/request when an HL7 'XX' code is received
"RTN","GMRCHL7B",98,0)
 ;This is currently not used.
"RTN","GMRCHL7B",99,0)
 ;    When Consults sends an XX, CPRS returns NA with a new order ien.
"RTN","GMRCHL7B",100,0)
 ;GMRCACT=processing activity - from file ^GMR(123.1,
"RTN","GMRCHL7B",101,0)
 S DIE="^GMR(123,",DA=+GMRCO
"RTN","GMRCHL7B",102,0)
 S GMRCWARD=$G(GMRCWARD),GMRCPRI=$G(GMRCPRI),GMRCURGI=$G(GMRCURGI),GMRCSTS=$G(GMRCSTS),GMRCTYPE=$G(GMRCTYPE),GMRCSS=$G(GMRCSS)
"RTN","GMRCHL7B",103,0)
 S GMRCACT=$O(^GMR(123.1,"D",GMRCTRLC,0))
"RTN","GMRCHL7B",104,0)
 S GMRCSTS=$P(^GMR(123.1,GMRCACT,0),"^",2)
"RTN","GMRCHL7B",105,0)
 S DIE=123,DR=".04////^S X=$G(GMRCWARD);1////^S X=$G(GMRCSS);4////^S X=$G(GMRCPRI);5////^S X=$G(GMRCURGI);8////^S X=$G(GMRCSTS);9////^S X=GMRCACT"
"RTN","GMRCHL7B",106,0)
 D ^DIE
"RTN","GMRCHL7B",107,0)
 D AUDIT0^GMRCHL7U
"RTN","GMRCHL7B",108,0)
 D EXIT Q
"RTN","GMRCHL7B",109,0)
REASON ;load the reason for request into ^GMR(123,IFN,20
"RTN","GMRCHL7B",110,0)
 S ^GMR(123,GMRCO,20,0)="^^^"_$S($D(GMRCDA):GMRCDA,1:DT)_"^"
"RTN","GMRCHL7B",111,0)
 S L=0,LN=1 F  S L=$O(GMRCRFQ(L)) Q:L=""  S ^GMR(123,GMRCO,20,LN,0)=GMRCRFQ(L),LN=LN+1
"RTN","GMRCHL7B",112,0)
 S LN=LN-1,$P(^GMR(123,GMRCO,20,0),"^",3)=LN
"RTN","GMRCHL7B",113,0)
 K L,LN
"RTN","GMRCHL7B",114,0)
 Q
"RTN","GMRCHL7B",115,0)
COMMENT(GMRCARY) ;add comments to the record.  Add the comment header, then the comment lines, and lastly, the number of comment lines to the header
"RTN","GMRCHL7B",116,0)
 ;GMRCARY= GMRCNTC array
"RTN","GMRCHL7B",117,0)
 S LN=0,^GMR(123,GMRCO,40,DA,1,0)="^^^^"_$P(GMRCDA,".",1)_"^"
"RTN","GMRCHL7B",118,0)
 F  S LN=$O(GMRCARY(LN)) Q:LN=""  S ^GMR(123,+GMRCO,40,DA,1,LN,0)=GMRCARY(LN),LN1=LN
"RTN","GMRCHL7B",119,0)
 S $P(^GMR(123,+GMRCO,40,DA,1,0),"^",3,4)=LN1_"^"_LN1
"RTN","GMRCHL7B",120,0)
 K LN,LN1 Q
"RTN","GMRCHL7B",121,0)
 Q
"RTN","GMRCHL7B",122,0)
EXIT ;kill off all variables
"RTN","GMRCHL7B",123,0)
 K DA,DIC,DIE,DR,GMRCORTX,GMRCADUZ
"RTN","GMRCHL7B",124,0)
 Q
"RTN","GMRCHL7U")
0^4^B26417808
"RTN","GMRCHL7U",1,0)
GMRCHL7U ;SLC/DCM,MA - Utilities assoc. with HL7 messages ;04/29/09  09:04
"RTN","GMRCHL7U",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,22,29,66**;DEC 27, 1997;Build 30
"RTN","GMRCHL7U",3,0)
 ; Patch #21 added more variables to in line tage EXIT.
"RTN","GMRCHL7U",4,0)
 ;
"RTN","GMRCHL7U",5,0)
 ; This routine invokes IA #872(FILE 101 ^ORD(100)), #2053(DIE), #10103(XLFDT), #10101(XQOR)
"RTN","GMRCHL7U",6,0)
 ;
"RTN","GMRCHL7U",7,0)
INIT(MSH) ;break out MSH segment separators and set other needed variables
"RTN","GMRCHL7U",8,0)
 ;MSH = MSH segment of the HL-7 message
"RTN","GMRCHL7U",9,0)
 N X
"RTN","GMRCHL7U",10,0)
 S (SEP1,SEP2,SEP3,SEP4,SEP5)=""
"RTN","GMRCHL7U",11,0)
 S SEP1=$E(MSH,4),X=$P(MSH,SEP1,2)
"RTN","GMRCHL7U",12,0)
 S SEP2=$E(X,1),SEP3=$E(X,2),SEP4=$E(X,3),SEP5=$E(X,4)
"RTN","GMRCHL7U",13,0)
 Q
"RTN","GMRCHL7U",14,0)
PID(GMRCPID) ;Get fields from PID segment and set into GMRC variables.
"RTN","GMRCHL7U",15,0)
 S DFN=$P(GMRCPID,SEP1,4),GMRCPNM=$P(GMRCPID,SEP1,6)
"RTN","GMRCHL7U",16,0)
 Q
"RTN","GMRCHL7U",17,0)
NTE(MSG,GMRCNTE,GMRCNODE,CTRLCODE) ;set NTE segments of HL-7 message into variables and globals
"RTN","GMRCHL7U",18,0)
 ;MSG = whole HL-7 array.
"RTN","GMRCHL7U",19,0)
 ;GMRCNTE = Node in array where NTE message begins
"RTN","GMRCHL7U",20,0)
 ;CTRLCODE = segment 1 of the ORC segment of HL-7 message
"RTN","GMRCHL7U",21,0)
 ;GMRCNODE = IEN of entry int file ^GMR(123,
"RTN","GMRCHL7U",22,0)
 N GMRCACT ;not sure why this is newed here
"RTN","GMRCHL7U",23,0)
 S GMRCAD=$G(GMRCAD),GMRCORNP=$G(GMRCORNP),GMRCFF=$G(GMRCFF),GMRCPA=$G(GMRCPA),GMRCDEV=$G(GMRCDEV)
"RTN","GMRCHL7U",24,0)
 S GMRCACT=$S(CTRLCODE="CA":19,CTRLCODE="DC":6,CTRLCODE="NW":1,1:$O(^GMR(123.1,"D",CTRLCODE,0)))
"RTN","GMRCHL7U",25,0)
 S GMRCNTC(1)=$P(MSG(GMRCNTE),SEP1,4)
"RTN","GMRCHL7U",26,0)
 S LN=0,LN1=2 F  S LN=$O(MSG(GMRCNTE,LN)) Q:LN=""  S GMRCNTC(LN1)=MSG(GMRCNTE,LN),LN1=LN1+1
"RTN","GMRCHL7U",27,0)
 K LN,LN1
"RTN","GMRCHL7U",28,0)
 Q
"RTN","GMRCHL7U",29,0)
PV1(GMRCPV1) ;Get fields from PV1 segment of HL-7 message and set into GMRC variables
"RTN","GMRCHL7U",30,0)
 ;GMRCRB  = patients room/bed            GMRCWARD=patients ward
"RTN","GMRCHL7U",31,0)
 ;GMRCSBR = service basis to be rendered (Inpatient or Outpatient)
"RTN","GMRCHL7U",32,0)
 N X
"RTN","GMRCHL7U",33,0)
 S X=$P(GMRCPV1,SEP1,3),GMRCSBR=$S(X]"":X,1:"")
"RTN","GMRCHL7U",34,0)
 S X=$P(GMRCPV1,SEP1,4),GMRCWARD=$S($P(X,SEP2,1)]"":$P(X,SEP2,1),1:""),VISIT=$S($P(GMRCPV1,SEP1,20)]"":$P(GMRCPV1,SEP1,20),1:"")
"RTN","GMRCHL7U",35,0)
 S GMRCRB=$S($P(X,SEP2,2)]"":$P(X,SEP2,2),1:"")
"RTN","GMRCHL7U",36,0)
 S:VISIT]"" GMRCVSIT=$$FMDATE^GMRCHL7(VISIT)
"RTN","GMRCHL7U",37,0)
 Q
"RTN","GMRCHL7U",38,0)
 ;
"RTN","GMRCHL7U",39,0)
REJECT(GMRCMSG,REAS) ;action can't be filed send reject message
"RTN","GMRCHL7U",40,0)
 N MSH,ORC,I ;GMRCMESS
"RTN","GMRCHL7U",41,0)
 S I=0 F  S I=$O(GMRCMSG(I)) Q:'I  D
"RTN","GMRCHL7U",42,0)
 . I $P(GMRCMSG(I),"|")="PID" S PID=GMRCMSG(I)
"RTN","GMRCHL7U",43,0)
 . I $P(GMRCMSG(I),"|")="ORC" D
"RTN","GMRCHL7U",44,0)
 .. N ORFN,GMRCFN,P17,CTRLCD
"RTN","GMRCHL7U",45,0)
 .. S ORFN=$P(GMRCMSG(I),"|",3),GMRCFN=$P(GMRCMSG(I),"|",4)
"RTN","GMRCHL7U",46,0)
 .. S CTRLCD=$P(GMRCMSG(I),"|",2)
"RTN","GMRCHL7U",47,0)
 .. S ORC="ORC|"_$S(CTRLCD="NW":"UA",1:"UD")_"|"_ORFN_"|"_GMRCFN
"RTN","GMRCHL7U",48,0)
 .. S P17=$S($D(REAS):REAS,1:"UNABLE TO FILE ACTION")
"RTN","GMRCHL7U",49,0)
 .. S $P(ORC,"|",17)="X^REJECTED^99ORN^^"_P17
"RTN","GMRCHL7U",50,0)
 S MSH=$$MSH^GMRCHL7
"RTN","GMRCHL7U",51,0)
 S $P(MSH,SEP1,9)="ORR"
"RTN","GMRCHL7U",52,0)
 S GMRCMESS(1)=MSH
"RTN","GMRCHL7U",53,0)
 S GMRCMESS(2)=PID
"RTN","GMRCHL7U",54,0)
 S GMRCMESS(3)=ORC
"RTN","GMRCHL7U",55,0)
 D MSG^XQOR("GMRC EVSEND OR",.GMRCMESS)
"RTN","GMRCHL7U",56,0)
 Q
"RTN","GMRCHL7U",57,0)
 ;
"RTN","GMRCHL7U",58,0)
RETURN(GMRCIEN,GMRCTRLC) ;return IEN of record in ^GMR(123,IEN, to OERR
"RTN","GMRCHL7U",59,0)
 ;GMRCIEN = internal record number of record in ^GMR(123,
"RTN","GMRCHL7U",60,0)
 ;GMRCTRLC=Control code from HL-7 Table 119
"RTN","GMRCHL7U",61,0)
 N MSH,PID,ORC,GMRCORCC
"RTN","GMRCHL7U",62,0)
 S SEP1="|",GMRCORCC=$S(GMRCTRLC="NW":"OK",GMRCTRLC="DC":"DR",1:"OK")
"RTN","GMRCHL7U",63,0)
 S MSH=$$MSH^GMRCHL7($G(X)) S $P(MSH,SEP1,9)="ORR"
"RTN","GMRCHL7U",64,0)
 S PID=$$PID^GMRCHL7(GMRCIEN)
"RTN","GMRCHL7U",65,0)
 D ORC^GMRCHL7(GMRCIEN,GMRCORCC,"") S ORC=$P(ORC,"|",1,4)
"RTN","GMRCHL7U",66,0)
 D BLD^GMRCHL7(MSH,PID,"",ORC,"","",,"",GMRCTRLC)
"RTN","GMRCHL7U",67,0)
 D MSG^XQOR("GMRC EVSEND OR",.GMRCMSG)
"RTN","GMRCHL7U",68,0)
 Q
"RTN","GMRCHL7U",69,0)
FILE(GMRCO,DR) ;File data into ^GMR(123,IEN,40 using ^DIE
"RTN","GMRCHL7U",70,0)
 N DIE,DA,GMRCACTI
"RTN","GMRCHL7U",71,0)
 ;GMRCO = IEN of record from file ^GMR(123,
"RTN","GMRCHL7U",72,0)
 ;DR = DR string required by ^DIE
"RTN","GMRCHL7U",73,0)
 Q:'$G(GMRCO)
"RTN","GMRCHL7U",74,0)
 L +^GMR(123,+GMRCO,40):$S($G(DILOCKTM)>0:DILOCKTM,1:5) S:'$D(^GMR(123,+GMRCO,40,0)) ^(0)="^123.02DA^^" ;wat/66 added lock timeout
"RTN","GMRCHL7U",75,0)
 S (DA,GMRCACTI)=$S($P(^GMR(123,+GMRCO,40,0),"^",3):$P(^(0),"^",3)+1,1:1),DA(1)=+GMRCO
"RTN","GMRCHL7U",76,0)
 S DIE="^GMR(123,"_GMRCO_",40,"
"RTN","GMRCHL7U",77,0)
 S $P(^GMR(123,+GMRCO,40,0),"^",3,4)=DA_"^"_DA
"RTN","GMRCHL7U",78,0)
 D ^DIE
"RTN","GMRCHL7U",79,0)
 I $D(GMRCNTC) D COMMENT^GMRCHL7B(.GMRCNTC)
"RTN","GMRCHL7U",80,0)
 I $D(GMRCCMT) D COMMENT^GMRCHL7B(.GMRCCMT)
"RTN","GMRCHL7U",81,0)
 D  ; if record is an IFC build and send update
"RTN","GMRCHL7U",82,0)
 . I '$D(^GMR(123,GMRCO,12)) Q
"RTN","GMRCHL7U",83,0)
 . D TRIGR^GMRCIEVT(GMRCO,GMRCACTI)
"RTN","GMRCHL7U",84,0)
 L -^GMR(123,+GMRCO,40)
"RTN","GMRCHL7U",85,0)
 Q
"RTN","GMRCHL7U",86,0)
EXIT ;Kill variables and exit
"RTN","GMRCHL7U",87,0)
 K HLQ,J,LN,ND,ND1,ND2,SEP1,SEP2,SEP3,SEP4,SEP5
"RTN","GMRCHL7U",88,0)
 K GMRCA,GMRCACT,GMRCAD,GMRCAP,GMRCAPP,GMRCATN,GMRCDA,GMRCDEV,GMRCFAC,GMRCFF,GMRCINTR,GMRCMTP,GMRCMSG,GMRCMSH,GMRCNOD,GMRCNTC,GMRCODT,GMRCOID,GMRCORFN,GMRCPA,GMRCPLCR,GMRCPLI,GMRCPNM,GMRCPR,GMRCPRI,GMRCFQ
"RTN","GMRCHL7U",89,0)
 K GMRCPRDG,GMRCSEND,GMRCSTDT,GMRCSTS,GMRCURGI,GMRCVAL,GMRCVTYP,GMRCWARD,GMRCPRV,GMRCTYPE,GMRCND,GMRCND1,VISIT
"RTN","GMRCHL7U",90,0)
 K GMRCRB,GMRCPRA,GMRCRFQ,MSH,OBXND,PID,GMRCORPV,GMRCOTXT,GMRCNATO,GMRCERDT ;WAT/66
"RTN","GMRCHL7U",91,0)
 K GMRCOFN,GMRCS123,GMRCS38,GMRCCMT
"RTN","GMRCHL7U",92,0)
 K GMRCTRLC,GMRCSS,GMRCO,GMRCORNP
"RTN","GMRCHL7U",93,0)
 Q
"RTN","GMRCHL7U",94,0)
AUDIT0 ;place activity audit tracking info into global ^GMR(123,IEN,40,
"RTN","GMRCHL7U",95,0)
 ;GMRCACT=processing activity (from ^GMR(123.1,
"RTN","GMRCHL7U",96,0)
 ;GMRCDA=date/time file entered     GMRCAD=date/time activity took place
"RTN","GMRCHL7U",97,0)
 ;GMRCORNP=name of provider         GMRCFF=forwared from (if forwarded)
"RTN","GMRCHL7U",98,0)
 ;GMRCPA=provider previously assigned
"RTN","GMRCHL7U",99,0)
 ;GMRCDEV=device printed to        GMRCCMT=comment array from OBX segment
"RTN","GMRCHL7U",100,0)
 N GMRCDA
"RTN","GMRCHL7U",101,0)
 S GMRCDA=$$NOW^XLFDT
"RTN","GMRCHL7U",102,0)
 L +^GMR(123,+GMRCO,40):$S($G(DILOCKTM)>0:DILOCKTM,1:5) S:'$D(^GMR(123,+GMRCO,40,0)) ^GMR(123,+GMRCO,40,0)="^123.02DA^^" ;wat/66 added lock timeout
"RTN","GMRCHL7U",103,0)
 S GMRCAD=$S($D(GMRCAD):GMRCAD,1:GMRCDA),GMRCORNP=$G(GMRCORNP),GMRCFF=$G(GMRCFF),GMRCPA=$G(GMRCPA),GMRCDEV=$G(GMRCDEV),GMRCPLCR=$G(GMRCPLCR)
"RTN","GMRCHL7U",104,0)
 ;Use the Control code from CPRS in 123.1 to determine the action.
"RTN","GMRCHL7U",105,0)
 ;If action undefined, then use "ADDED COMMENT", entry 20.
"RTN","GMRCHL7U",106,0)
 S GMRCACT=$O(^GMR(123.1,"D",GMRCTRLC,0))
"RTN","GMRCHL7U",107,0)
 S:'GMRCACT GMRCACT=20
"RTN","GMRCHL7U",108,0)
 S DR=".01////^S X=GMRCDA;1////^S X=GMRCACT;2////^S X=GMRCAD;3////^S X=GMRCORNP;4////^S X=GMRCPLCR;6////^S X=GMRCFF;7////^S X=GMRCPA;8////^S X=GMRCDEV"
"RTN","GMRCHL7U",109,0)
 D FILE(GMRCO,DR)
"RTN","GMRCHL7U",110,0)
 L -^GMR(123,+GMRCO,40)
"RTN","GMRCHL7U",111,0)
 Q
"RTN","GMRCHL7U",112,0)
ALERT(GMRCDFN,GMRCSS,GMRCPR,GMRCFN,GMRCURG,GMRCORA) ;generate an alert when receiving a consult
"RTN","GMRCHL7U",113,0)
 ;GMRCDFN=patient DFN from file 2
"RTN","GMRCHL7U",114,0)
 ;GMRCSS=Service
"RTN","GMRCHL7U",115,0)
 ;GMRCPR=procedure being ordered
"RTN","GMRCHL7U",116,0)
 ;GMRCFN=File 123 IEN
"RTN","GMRCHL7U",117,0)
 ;GMRCURG=urgency of request from protocol file
"RTN","GMRCHL7U",118,0)
 ;GMRCADUZ=array of those who receive alerts
"RTN","GMRCHL7U",119,0)
 ;GMRCORA=action to take on alert: 27 is for new alert
"RTN","GMRCHL7U",120,0)
 N GMRCORTX
"RTN","GMRCHL7U",121,0)
 S GMRCORTX="New consult "_$$ORTX^GMRCAU(+GMRCO)_$S(+GMRCURG:" ("_$P(^ORD(101,+GMRCURG,0),"^",2)_")",1:"")
"RTN","GMRCHL7U",122,0)
 S:'$D(GMRCORA) GMRCORA=27 S:GMRCORA="" GMRCORA=27
"RTN","GMRCHL7U",123,0)
 D MSG^GMRCP(GMRCDFN,GMRCORTX,GMRCFN,GMRCORA,.GMRCADUZ,1)
"RTN","GMRCHL7U",124,0)
 K GMRCADUZ
"RTN","GMRCHL7U",125,0)
 Q
"RTN","GMRCIAC1")
0^5^B69544228
"RTN","GMRCIAC1",1,0)
GMRCIAC1 ;SLC/JFR - FILE IFC ACTIVITIES cont'd ;04/29/09  12:09
"RTN","GMRCIAC1",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**22,66**;DEC 27, 1997;Build 30
"RTN","GMRCIAC1",3,0)
 ;#2051($$FIND1^DIC), #2053(DIE)
"RTN","GMRCIAC1",4,0)
 Q
"RTN","GMRCIAC1",5,0)
COMP(GMRCAR) ;process partial result, clin complete and admin complete
"RTN","GMRCIAC1",6,0)
 ;
"RTN","GMRCIAC1",7,0)
 N GMRCDA,GMRCFDA,GMRCORC,GMRCLAT,GMRCACT,FDA
"RTN","GMRCIAC1",8,0)
 N GMRCRES,GMRCERR,GMRCSTS,GMRCREAS
"RTN","GMRCIAC1",9,0)
 M ^TMP("GMRCIN",$J)=@GMRCAR
"RTN","GMRCIAC1",10,0)
 S GMRCORC=^TMP("GMRCIN",$J,"ORC")
"RTN","GMRCIAC1",11,0)
 S GMRCREAS=$P($P(GMRCORC,"|",16),U)
"RTN","GMRCIAC1",12,0)
 S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
"RTN","GMRCIAC1",13,0)
 S GMRCSTS=$P(^GMR(123,GMRCDA,0),U,12)
"RTN","GMRCIAC1",14,0)
 I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
"RTN","GMRCIAC1",15,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AR",901) ;send app. ACK
"RTN","GMRCIAC1",16,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIAC1",17,0)
 ;
"RTN","GMRCIAC1",18,0)
 S GMRCFDA(8)=$S($P(GMRCORC,"|",5)="CM":2,GMRCSTS=2:2,1:9) ;comp or pr
"RTN","GMRCIAC1",19,0)
 S GMRCLAT=$S($P(GMRCORC,"|",5)="A":9,GMRCREAS="A":13,1:10)
"RTN","GMRCIAC1",20,0)
 S GMRCFDA(9)=GMRCLAT ;complete/upd or incomplete rpt
"RTN","GMRCIAC1",21,0)
 I $D(^TMP("GMRCIN",$J,"OBX",6,1)) D
"RTN","GMRCIAC1",22,0)
 . S GMRCFDA(15)=$P(^TMP("GMRCIN",$J,"OBX",6,1),"|",5)
"RTN","GMRCIAC1",23,0)
 ;     v-- check to see if a duplicate transmission
"RTN","GMRCIAC1",24,0)
 I $$DUPACT^GMRCIAC2(GMRCDA,GMRCLAT,GMRCORC,$S(GMRCLAT=13:"",1:$G(^TMP("GMRCIN",$J,"OBX",4,1)))) Q
"RTN","GMRCIAC1",25,0)
 M FDA(1,123,GMRCDA_",")=GMRCFDA
"RTN","GMRCIAC1",26,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and status
"RTN","GMRCIAC1",27,0)
 ; check GMRCERR and act if error
"RTN","GMRCIAC1",28,0)
 K GMRCERR
"RTN","GMRCIAC1",29,0)
 K GMRCFDA,FDA
"RTN","GMRCIAC1",30,0)
 D FILEACT^GMRCIAC2(GMRCDA,GMRCLAT,,$NA(^TMP("GMRCIN",$J)))
"RTN","GMRCIAC1",31,0)
 ;     ^--- file result and activities
"RTN","GMRCIAC1",32,0)
 I $D(^TMP("GMRCIN",$J,"OBX",4,1)) D  ;file result if there
"RTN","GMRCIAC1",33,0)
 . I GMRCLAT=13 Q  ; addendum carries the result that it's addending
"RTN","GMRCIAC1",34,0)
 . I GMRCLAT=9 Q  ; don't file result on inc. report
"RTN","GMRCIAC1",35,0)
 . I $P(^GMR(123,GMRCDA,12),U,5)="F" Q  ;no comp coming from placer
"RTN","GMRCIAC1",36,0)
 . D FILRES^GMRCIAC2(GMRCDA,^TMP("GMRCIN",$J,"OBX",4,1))
"RTN","GMRCIAC1",37,0)
 D  ;send notifications
"RTN","GMRCIAC1",38,0)
 . I GMRCLAT=9 Q
"RTN","GMRCIAC1",39,0)
 . I $P(^GMR(123,GMRCDA,12),U,5)="F" Q  ;filler only gets historical comp
"RTN","GMRCIAC1",40,0)
 . N GMRCORTX S GMRCORTX=""
"RTN","GMRCIAC1",41,0)
 . I $O(^GMR(123,GMRCDA,51," "),-1)>1 D
"RTN","GMRCIAC1",42,0)
 .. S GMRCORTX="New remote result added to "
"RTN","GMRCIAC1",43,0)
 . I GMRCLAT=13 S GMRCORTX="Addendum added to "
"RTN","GMRCIAC1",44,0)
 . S GMRCORTX=GMRCORTX_"Remote Complete Consult: "_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIAC1",45,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,23,,1)
"RTN","GMRCIAC1",46,0)
 D  ;send appl ACK
"RTN","GMRCIAC1",47,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AA")
"RTN","GMRCIAC1",48,0)
 ;
"RTN","GMRCIAC1",49,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIAC1",50,0)
 Q
"RTN","GMRCIAC1",51,0)
 ;
"RTN","GMRCIAC1",52,0)
FWD(GMRCAR)     ;file forward action from a remote site
"RTN","GMRCIAC1",53,0)
 ;Input:
"RTN","GMRCIAC1",54,0)
 ; GMRCAR = array name containing message
"RTN","GMRCIAC1",55,0)
 ;      e.g.  ^TMP("GMRCIF",$J)
"RTN","GMRCIAC1",56,0)
 ;
"RTN","GMRCIAC1",57,0)
 N GMRCFDA,GMRCDA,GMRCFWSR,GMRCFROM,GMRCORC,GMRCTIFC,GMRCLAC,GMRCROL
"RTN","GMRCIAC1",58,0)
 M ^TMP("GMRCIN",$J)=@GMRCAR
"RTN","GMRCIAC1",59,0)
 I '$D(^TMP("GMRCIN",$J,"OBR")) Q
"RTN","GMRCIAC1",60,0)
 S GMRCORC=^TMP("GMRCIN",$J,"ORC")
"RTN","GMRCIAC1",61,0)
 S GMRCTIFC=$S($P($P(GMRCORC,"|",16),U)="F":0,1:1)
"RTN","GMRCIAC1",62,0)
 S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
"RTN","GMRCIAC1",63,0)
 I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
"RTN","GMRCIAC1",64,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AR",901) ;send app. ACK
"RTN","GMRCIAC1",65,0)
        . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIAC1",66,0)
 S GMRCROL=$P(^GMR(123,GMRCDA,12),U,5)
"RTN","GMRCIAC1",67,0)
 I 'GMRCTIFC D
"RTN","GMRCIAC1",68,0)
 . S GMRCFDA(9)=17,GMRCLAC=17
"RTN","GMRCIAC1",69,0)
 . I GMRCROL="F" D  Q
"RTN","GMRCIAC1",70,0)
 .. S GMRCFROM=$P($P(^TMP("GMRCIN",$J,"OBR"),"|",4),U,2)
"RTN","GMRCIAC1",71,0)
 . S GMRCFDA(.131)=$P($P(^TMP("GMRCIN",$J,"OBR"),"|",4),U,2)
"RTN","GMRCIAC1",72,0)
 . S GMRCFROM=$P($G(^GMR(123,GMRCDA,13)),U)
"RTN","GMRCIAC1",73,0)
 I GMRCTIFC D
"RTN","GMRCIAC1",74,0)
 . S GMRCFROM=$P($P(^TMP("GMRCIN",$J,"OBR"),"|",4),U,2)
"RTN","GMRCIAC1",75,0)
 . S GMRCFDA(9)=25,GMRCLAC=25
"RTN","GMRCIAC1",76,0)
 ;
"RTN","GMRCIAC1",77,0)
 S GMRCFDA(8)=5
"RTN","GMRCIAC1",78,0)
 D  ;get urgency to file
"RTN","GMRCIAC1",79,0)
 . N URG
"RTN","GMRCIAC1",80,0)
 . S URG=$$URG^GMRCHL7A($P($P(^TMP("GMRCIN",$J,"ORC"),"|",7),U,6))
"RTN","GMRCIAC1",81,0)
 . S GMRCFDA(5)=$$FIND1^DIC(101,"","X","GMRCURGENCY - "_URG)
"RTN","GMRCIAC1",82,0)
 ;   v-- chk to see if activity is a dup transmission
"RTN","GMRCIAC1",83,0)
 I $$DUPACT^GMRCIAC2(GMRCDA,GMRCLAC,GMRCORC) Q
"RTN","GMRCIAC1",84,0)
 ;
"RTN","GMRCIAC1",85,0)
 M FDA(1,123,GMRCDA_",")=GMRCFDA
"RTN","GMRCIAC1",86,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR")
"RTN","GMRCIAC1",87,0)
 K GMRCFDA
"RTN","GMRCIAC1",88,0)
 ;
"RTN","GMRCIAC1",89,0)
 ; file activity tracking
"RTN","GMRCIAC1",90,0)
 D FILEACT^GMRCIAC2(GMRCDA,GMRCLAC,GMRCFROM,$NA(^TMP("GMRCIN",$J)))
"RTN","GMRCIAC1",91,0)
 ;
"RTN","GMRCIAC1",92,0)
 ; send alerts
"RTN","GMRCIAC1",93,0)
 I GMRCROL="F" D
"RTN","GMRCIAC1",94,0)
 . I GMRCLAC'=25 Q  ; filler alerts only on FWD 2 IFC
"RTN","GMRCIAC1",95,0)
 . N GMRCTX
"RTN","GMRCIAC1",96,0)
 . S GMRCTX="New remote Consult: "_$$ORTX^GMRCAU(GMRCDA)
"RTN","GMRCIAC1",97,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCTX,GMRCDA,27,,1)
"RTN","GMRCIAC1",98,0)
 . Q
"RTN","GMRCIAC1",99,0)
 I GMRCROL="P" D
"RTN","GMRCIAC1",100,0)
 . N GMRCTX
"RTN","GMRCIAC1",101,0)
 . S GMRCTX="Updated Remote Consult: "_$$ORTX^GMRCAU(GMRCDA)
"RTN","GMRCIAC1",102,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCTX,GMRCDA,63,,1)
"RTN","GMRCIAC1",103,0)
 . Q
"RTN","GMRCIAC1",104,0)
 ;
"RTN","GMRCIAC1",105,0)
 ; print if FWD to IFC
"RTN","GMRCIAC1",106,0)
 I GMRCROL="F" D
"RTN","GMRCIAC1",107,0)
 . I GMRCLAC'=25 Q
"RTN","GMRCIAC1",108,0)
 . D PRNT^GMRCUTL1("",GMRCDA)
"RTN","GMRCIAC1",109,0)
 ;
"RTN","GMRCIAC1",110,0)
 D  ;send app. ACK and unlock record
"RTN","GMRCIAC1",111,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AA")
"RTN","GMRCIAC1",112,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIAC1",113,0)
 Q
"RTN","GMRCIAC1",114,0)
 ;
"RTN","GMRCIAC1",115,0)
SF(GMRCAR) ;add significant findings
"RTN","GMRCIAC1",116,0)
 ; Input:
"RTN","GMRCIAC1",117,0)
 ; GMRCAR = array name containing message
"RTN","GMRCIAC1",118,0)
 ;      e.g.  ^TMP("GMRCIF",$J)
"RTN","GMRCIAC1",119,0)
 ;
"RTN","GMRCIAC1",120,0)
 N FDA,GMRCERR,GMRCOSF,GMRCISF
"RTN","GMRCIAC1",121,0)
 M ^TMP("GMRCIS",$J)=@GMRCAR
"RTN","GMRCIAC1",122,0)
 I '$D(^TMP("GMRCIS",$J,"OBX",6,1)) Q  ;no SF flag sent  ;-(
"RTN","GMRCIAC1",123,0)
 S GMRCDA=$$GETDA^GMRCIAC2(^TMP("GMRCIS",$J,"ORC"))
"RTN","GMRCIAC1",124,0)
 I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
"RTN","GMRCIAC1",125,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AR",901) ;send app. ACK
"RTN","GMRCIAC1",126,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIAC1",127,0)
 ;
"RTN","GMRCIAC1",128,0)
 S GMRCOSF=$P(^GMR(123,GMRCDA,0),U,19)
"RTN","GMRCIAC1",129,0)
 S GMRCISF=$P(^TMP("GMRCIS",$J,"OBX",6,1),"|",5)
"RTN","GMRCIAC1",130,0)
 S FDA(1,123,GMRCDA_",",15)=GMRCISF
"RTN","GMRCIAC1",131,0)
 S FDA(1,123,GMRCDA_",",9)=4
"RTN","GMRCIAC1",132,0)
 ;   v-- quit if a duplicate activity
"RTN","GMRCIAC1",133,0)
 I $$DUPACT^GMRCIAC2(GMRCDA,4,^TMP("GMRCIS",$J,"ORC")) Q
"RTN","GMRCIAC1",134,0)
 ;
"RTN","GMRCIAC1",135,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and SF
"RTN","GMRCIAC1",136,0)
 D FILEACT^GMRCIAC2(GMRCDA,4,,$NA(^TMP("GMRCIS",$J))) ;activity track
"RTN","GMRCIAC1",137,0)
 D  ;send notifications
"RTN","GMRCIAC1",138,0)
 . I $P(^GMR(123,GMRCDA,12),U,5)="F" Q  ;filler only gets hist. SF
"RTN","GMRCIAC1",139,0)
 . N GMRCORTX
"RTN","GMRCIAC1",140,0)
 . S GMRCORTX=$S(GMRCISF="N":"No ",GMRCISF="Y":"",1:"Unknown ")
"RTN","GMRCIAC1",141,0)
 . S GMRCORTX=GMRCORTX_"Sig Findings for "_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIAC1",142,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,23,,1)
"RTN","GMRCIAC1",143,0)
 D  ;send appl ACK and unlock record
"RTN","GMRCIAC1",144,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AA")
"RTN","GMRCIAC1",145,0)
 K ^TMP("GMRCIS",$J)
"RTN","GMRCIAC1",146,0)
 Q
"RTN","GMRCIAC1",147,0)
 ;
"RTN","GMRCIAC1",148,0)
RESUB(GMRCAR) ;resubmit a cancelled, remote consult
"RTN","GMRCIAC1",149,0)
 ; Input:
"RTN","GMRCIAC1",150,0)
 ;   GMRCAR - array name containing message
"RTN","GMRCIAC1",151,0)
 ;      e.g.  ^TMP("GMRCIF",$J)
"RTN","GMRCIAC1",152,0)
 ;
"RTN","GMRCIAC1",153,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIAC1",154,0)
 M ^TMP("GMRCIN",$J)=@GMRCAR
"RTN","GMRCIAC1",155,0)
 N GMRCDA,GMRCFDA,FDA
"RTN","GMRCIAC1",156,0)
 S GMRCDA=$$GETDA^GMRCIAC2(^TMP("GMRCIN",$J,"ORC"))
"RTN","GMRCIAC1",157,0)
 I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
"RTN","GMRCIAC1",158,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AR",901) ; send app. ACK
"RTN","GMRCIAC1",159,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIAC1",160,0)
 ;
"RTN","GMRCIAC1",161,0)
 S GMRCFDA(8)=5,GMRCFDA(9)=11 ;status and last action
"RTN","GMRCIAC1",162,0)
 ;
"RTN","GMRCIAC1",163,0)
 I $D(^TMP("GMRCIN",$J,"OBR")) D  ; has INPATIENT or OUTPATIENT changed?
"RTN","GMRCIAC1",164,0)
 . N GMRCION
"RTN","GMRCIAC1",165,0)
 . S GMRCION=$P(^TMP("GMRCIN",$J,"OBR"),"|",18)
"RTN","GMRCIAC1",166,0)
 . I GMRCION'=$P(^GMR(123,GMRCDA,0),U,18) S GMRCFDA(14)=GMRCION
"RTN","GMRCIAC1",167,0)
 . Q
"RTN","GMRCIAC1",168,0)
 D  ; check for change in urgency
"RTN","GMRCIAC1",169,0)
 . N GMRCURG
"RTN","GMRCIAC1",170,0)
 . S GMRCURG=$P($P(^TMP("GMRCIN",$J,"ORC"),"|",7),U,6)
"RTN","GMRCIAC1",171,0)
 . I '$L(GMRCURG) Q
"RTN","GMRCIAC1",172,0)
 . S GMRCURG=$$URG^GMRCHL7A(GMRCURG)
"RTN","GMRCIAC1",173,0)
 . S GMRCURG=$$FIND1^DIC(101,"","X","GMRCURGENCY - "_GMRCURG)
"RTN","GMRCIAC1",174,0)
 . I GMRCURG'>1 Q
"RTN","GMRCIAC1",175,0)
 . I GMRCURG=$P(^GMR(123,GMRCDA,0),U,9) Q  ;no change
"RTN","GMRCIAC1",176,0)
 . S GMRCFDA(5)=GMRCURG
"RTN","GMRCIAC1",177,0)
 . Q
"RTN","GMRCIAC1",178,0)
 D  ;check for change earliest date WAT/66
"RTN","GMRCIAC1",179,0)
 . N GMRCERDT
"RTN","GMRCIAC1",180,0)
 . S GMRCERDT=$P($P(^TMP("GMRCIN",$J,"ORC"),"|",7),U,4)
"RTN","GMRCIAC1",181,0)
 . I '$L(GMRCERDT) Q
"RTN","GMRCIAC1",182,0)
 . S GMRCERDT=$$FMDATE^GMRCHL7(GMRCERDT)
"RTN","GMRCIAC1",183,0)
 . I GMRCERDT=$P(^GMR(123,GMRCDA,0),U,24) Q  ;no change
"RTN","GMRCIAC1",184,0)
 . S GMRCFDA(17)=GMRCERDT
"RTN","GMRCIAC1",185,0)
 . Q
"RTN","GMRCIAC1",186,0)
 I $D(^TMP("GMRCIN",$J,"OBX",2)) D  ; change in Prov. DX?
"RTN","GMRCIAC1",187,0)
 . N PROVDX
"RTN","GMRCIAC1",188,0)
 . S PROVDX=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U,2)
"RTN","GMRCIAC1",189,0)
 . I '$L(PROVDX) Q
"RTN","GMRCIAC1",190,0)
 . I PROVDX=$G(^GMR(123,GMRCDA,30)) Q  ; no change
"RTN","GMRCIAC1",191,0)
 . S GMRCFDA(30)=PROVDX
"RTN","GMRCIAC1",192,0)
 . S GMRCFDA(30.1)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U)
"RTN","GMRCIAC1",193,0)
 . Q
"RTN","GMRCIAC1",194,0)
 ;   v-- QUIT if a duplicate transmission
"RTN","GMRCIAC1",195,0)
 I $$DUPACT^GMRCIAC2(GMRCDA,11,^TMP("GMRCIN",$J,"ORC")) Q
"RTN","GMRCIAC1",196,0)
 ;
"RTN","GMRCIAC1",197,0)
 M FDA(1,123,GMRCDA_",")=GMRCFDA
"RTN","GMRCIAC1",198,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file edits
"RTN","GMRCIAC1",199,0)
 K GMRCFDA,FDA
"RTN","GMRCIAC1",200,0)
 ;
"RTN","GMRCIAC1",201,0)
 I $D(^TMP("GMRCIN",$J,"OBX",1)) D  ; reason for request change?
"RTN","GMRCIAC1",202,0)
 . D TRIMWP^GMRCIUTL($NA(^TMP("GMRCIN",$J,"OBX",1)),5)
"RTN","GMRCIAC1",203,0)
 . N DIFF S DIFF=0
"RTN","GMRCIAC1",204,0)
 . D  I 'DIFF Q
"RTN","GMRCIAC1",205,0)
 .. I $O(^TMP("GMRCIN",$J,"OBX",1," "),-1)'=$O(^GMR(123,GMRCDA,20," "),-1) S DIFF=1 Q  ;  diff # of lines in new and existing
"RTN","GMRCIAC1",206,0)
 .. N LN S LN=0 F  S LN=$O(^GMR(123,GMRCDA,20,LN)) Q:'LN!(DIFF)  D
"RTN","GMRCIAC1",207,0)
 ... I $G(^GMR(123,GMRCDA,20,LN,0))=$G(^TMP("GMRCIN",$J,"OBX",1,LN)) Q
"RTN","GMRCIAC1",208,0)
 ... S DIFF=1 ;if the lines aren't the same, set DIFF and Q
"RTN","GMRCIAC1",209,0)
 . D WP^DIE(123,GMRCDA_",",20,"K",$NA(^TMP("GMRCIN",$J,"OBX",1)))
"RTN","GMRCIAC1",210,0)
 . Q
"RTN","GMRCIAC1",211,0)
 D  ;file activity tracking
"RTN","GMRCIAC1",212,0)
 . D FILEACT^GMRCIAC2(GMRCDA,11,,$NA(^TMP("GMRCIN",$J)))
"RTN","GMRCIAC1",213,0)
 N GMRCNTIF
"RTN","GMRCIAC1",214,0)
 D  ;determine if part of a FWD to IFC
"RTN","GMRCIAC1",215,0)
 . I $P(^GMR(123,GMRCDA,40,1,0),U,2)'=24 S GMRCNTIF=1 Q
"RTN","GMRCIAC1",216,0)
 . N ACT S ACT=1
"RTN","GMRCIAC1",217,0)
 . S GMRCNTIF=0
"RTN","GMRCIAC1",218,0)
 . F  S ACT=$O(^GMR(123,GMRCDA,40,ACT)) Q:'ACT!($G(GMRCNTIF))  D
"RTN","GMRCIAC1",219,0)
 .. I ($P(^GMR(123,GMRCDA,40,ACT,0),U,2)=25),$O(^GMR(123,GMRCDA,40,ACT)) S GMRCNTIF=1 ;wat/66 Remedy 278355
"RTN","GMRCIAC1",220,0)
 ;
"RTN","GMRCIAC1",221,0)
 D  ;print SF-513 & send notifications
"RTN","GMRCIAC1",222,0)
 . I '$G(GMRCNTIF) Q  ;part of a FWD to IFC
"RTN","GMRCIAC1",223,0)
 . D PRNT^GMRCUTL1("",GMRCDA)
"RTN","GMRCIAC1",224,0)
 . N GMRCORTX
"RTN","GMRCIAC1",225,0)
 . S GMRCORTX="New remotely re-submitted consult "
"RTN","GMRCIAC1",226,0)
 . S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIAC1",227,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,27,,1)
"RTN","GMRCIAC1",228,0)
 ;
"RTN","GMRCIAC1",229,0)
 D  ;send appl ACK and unlock record
"RTN","GMRCIAC1",230,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AA")
"RTN","GMRCIAC1",231,0)
 ;
"RTN","GMRCIAC1",232,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIAC1",233,0)
 Q
"RTN","GMRCIAC1",234,0)
 ;
"RTN","GMRCIAC2")
0^19^B38779618
"RTN","GMRCIAC2",1,0)
GMRCIAC2 ;SLC/JFR - FILE IFC ACTIVITIES CONT'D ;08/16/10  08:34
"RTN","GMRCIAC2",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,35,66**;DEC 27, 1997;Build 30
"RTN","GMRCIAC2",3,0)
 ;;ICRs in use
"RTN","GMRCIAC2",4,0)
 ;;#2053 DIE, #2171 XUAF4, #10103 XLFDT, #2541 $$KSP^XUPARAM, #2165 HLMA1
"RTN","GMRCIAC2",5,0)
 Q  ;can't start here
"RTN","GMRCIAC2",6,0)
FILRES(GMRCO,GMRCOBX) ;file or delete results
"RTN","GMRCIAC2",7,0)
 N GMRCRES,GMRCFIL,GMRCSITE,GMRCROOT,RESIEN,GMRCERR
"RTN","GMRCIAC2",8,0)
 S GMRCRES=+$P(GMRCOBX,"|",5)
"RTN","GMRCIAC2",9,0)
 S GMRCFIL=$P($P(GMRCOBX,"|",3),U,3)
"RTN","GMRCIAC2",10,0)
 S GMRCROOT=$S($P($P(GMRCOBX,"|",3),U,2)["TIU":"TIU(",1:"MCAR(")
"RTN","GMRCIAC2",11,0)
 S GMRCFIL=$P(GMRCFIL,"VA",2)
"RTN","GMRCIAC2",12,0)
 S GMRCRES=GMRCRES_";"_GMRCROOT_GMRCFIL
"RTN","GMRCIAC2",13,0)
 S GMRCSITE=$$IEN^XUAF4($P($P(GMRCOBX,"|",5),U,3))
"RTN","GMRCIAC2",14,0)
 I $P(GMRCOBX,"|",11)'="D" D  ;add new result
"RTN","GMRCIAC2",15,0)
 . S FDA(1,123.051,"+1,"_GMRCO_",",.01)=$$NOW^XLFDT
"RTN","GMRCIAC2",16,0)
 . S FDA(1,123.051,"+1,"_GMRCO_",",.02)=GMRCRES
"RTN","GMRCIAC2",17,0)
 . S FDA(1,123.051,"+1,"_GMRCO_",",.03)=GMRCSITE
"RTN","GMRCIAC2",18,0)
 I $P(GMRCOBX,"|",11)="D" D  ; find and delete result
"RTN","GMRCIAC2",19,0)
 . N RESIEN
"RTN","GMRCIAC2",20,0)
 . S RESIEN=$O(^GMR(123,GMRCO,51,"AR",GMRCRES,GMRCSITE,0))
"RTN","GMRCIAC2",21,0)
 . I 'RESIEN Q
"RTN","GMRCIAC2",22,0)
 . S FDA(1,123.051,RESIEN_","_GMRCO_",",.01)="@"
"RTN","GMRCIAC2",23,0)
 I '$D(FDA) Q
"RTN","GMRCIAC2",24,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR")
"RTN","GMRCIAC2",25,0)
 Q
"RTN","GMRCIAC2",26,0)
 ;
"RTN","GMRCIAC2",27,0)
UPDORD(GMRCDA,GMRC40) ; update CPRS order if action on placer order.
"RTN","GMRCIAC2",28,0)
 ; Input:
"RTN","GMRCIAC2",29,0)
 ;  GMRCDA   = ien from file 123
"RTN","GMRCIAC2",30,0)
 ;  GMRC40 = ien of activity in 40 multiple
"RTN","GMRCIAC2",31,0)
 ;
"RTN","GMRCIAC2",32,0)
 N GMRCDFN,GMRCAD,AC,GMRCOC,GMRCMT
"RTN","GMRCIAC2",33,0)
 S GMRCDFN=$P(^GMR(123,GMRCDA,0),U,2)
"RTN","GMRCIAC2",34,0)
 I $O(^GMR(123,GMRCDA,40,GMRC40,1,0)) D
"RTN","GMRCIAC2",35,0)
 . S GMRCMT=1,GMRCMT(0)=GMRC40
"RTN","GMRCIAC2",36,0)
 S GMRCAD=$P(^GMR(123,GMRCDA,40,GMRC40,0),U,3)
"RTN","GMRCIAC2",37,0)
 S AC=$P(^GMR(123,GMRCDA,40,GMRC40,0),U,2)
"RTN","GMRCIAC2",38,0)
 S GMRCOC=$S(AC=6:"OD",AC=19:"OC",AC=10:"RE",AC=9:"RE",AC=8:"ZC",1:"SC")
"RTN","GMRCIAC2",39,0)
 D EN^GMRCHL7(GMRCDFN,GMRCDA,"","",GMRCOC,"","",.GMRCMT,,GMRCAD)
"RTN","GMRCIAC2",40,0)
 Q
"RTN","GMRCIAC2",41,0)
FILEACT(GMRCO,GMRCLAST,GMRCFR,GMRCAR) ;file REQUEST PROCESSING ACTIVITY
"RTN","GMRCIAC2",42,0)
 ; Input:
"RTN","GMRCIAC2",43,0)
 ;  GMRCO     = ien from file 123
"RTN","GMRCIAC2",44,0)
 ;  GMRCLAST  = last action taken on request
"RTN","GMRCIAC2",45,0)
 ;  GMRCFR    = service that consult was forwarded from
"RTN","GMRCIAC2",46,0)
 ;  GMRCAR    = name of the array containing the message
"RTN","GMRCIAC2",47,0)
 ;
"RTN","GMRCIAC2",48,0)
 N GMRCORC,GMRCFDA,GMRCRP,GMRCEP,GMRCACT,GMRCERR,FDA
"RTN","GMRCIAC2",49,0)
 M ^TMP("GMRCFIL",$J)=@GMRCAR
"RTN","GMRCIAC2",50,0)
 S GMRCORC=^TMP("GMRCFIL",$J,"ORC")
"RTN","GMRCIAC2",51,0)
 S GMRCFDA(.01)=$$NOW^XLFDT
"RTN","GMRCIAC2",52,0)
 S GMRCFDA(.25)=$$HL7TFM^XLFDT($P(GMRCORC,"|",9))
"RTN","GMRCIAC2",53,0)
 S GMRCFDA(1)=GMRCLAST
"RTN","GMRCIAC2",54,0)
 S GMRCFDA(2)=$$HL7TFM^XLFDT($P(GMRCORC,"|",15))
"RTN","GMRCIAC2",55,0)
 D  ;get entering and responsible persons
"RTN","GMRCIAC2",56,0)
 . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",10),.GMRCEP,0,U)
"RTN","GMRCIAC2",57,0)
 . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",12),.GMRCRP,0,U)
"RTN","GMRCIAC2",58,0)
 S GMRCFDA(.21)=GMRCEP
"RTN","GMRCIAC2",59,0)
 S GMRCFDA(.22)=GMRCRP
"RTN","GMRCIAC2",60,0)
 S GMRCFDA(.23)=$P($G(^TMP("GMRCFIL",$J,"OBX",5,1)),"|",5)
"RTN","GMRCIAC2",61,0)
 I $D(GMRCFR) S GMRCFDA(.31)=GMRCFR
"RTN","GMRCIAC2",62,0)
 I $D(^TMP("GMRCFIL",$J,"OBX",4)) D
"RTN","GMRCIAC2",63,0)
 . N RFIL,RSLT,DESC,GMRCOBX,ROOT,RSITE
"RTN","GMRCIAC2",64,0)
 . S GMRCOBX=^TMP("GMRCFIL",$J,"OBX",4,1)
"RTN","GMRCIAC2",65,0)
 . S RFIL=$P($P(GMRCOBX,"|",3),U,3),RFIL=$P(RFIL,"VA",2)
"RTN","GMRCIAC2",66,0)
 . S RSLT=+$P(GMRCOBX,"|",5)
"RTN","GMRCIAC2",67,0)
 . S RSITE=$$IEN^XUAF4($P($P(GMRCOBX,"|",5),U,3))
"RTN","GMRCIAC2",68,0)
 . S ROOT=$S($P($P(GMRCOBX,"|",3),U,2)["TIU":"TIU(",1:"MCAR(")
"RTN","GMRCIAC2",69,0)
 . S DESC=$P($P(GMRCOBX,"|",5),U,2)
"RTN","GMRCIAC2",70,0)
 . S GMRCFDA(.24)=RSLT_";"_ROOT_RFIL_";"_DESC_";"_RSITE
"RTN","GMRCIAC2",71,0)
 I GMRCLAST=10 D  ; overwite inc. report in last action?
"RTN","GMRCIAC2",72,0)
 . N GMRCLACT
"RTN","GMRCIAC2",73,0)
 . S GMRCLACT=$O(^GMR(123,GMRCO,40," "),-1)
"RTN","GMRCIAC2",74,0)
 . I '$G(GMRCLACT) Q
"RTN","GMRCIAC2",75,0)
 . I $P($G(^GMR(123,GMRCO,40,GMRCLACT,0)),U,2)'=9 Q
"RTN","GMRCIAC2",76,0)
 . I $$FMDIFF^XLFDT($$NOW^XLFDT,+^GMR(123,GMRCO,40,GMRCLACT,0),2)>900 Q
"RTN","GMRCIAC2",77,0)
 . I $P($G(^GMR(123,GMRCO,40,GMRCLACT,2)),U,4)=GMRCFDA(.24) D
"RTN","GMRCIAC2",78,0)
 .. S GMRCACT(1)=GMRCLACT
"RTN","GMRCIAC2",79,0)
 .. M FDA(1,123.02,GMRCACT(1)_","_GMRCO_",")=GMRCFDA
"RTN","GMRCIAC2",80,0)
 .. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
"RTN","GMRCIAC2",81,0)
 . Q
"RTN","GMRCIAC2",82,0)
 I '$D(GMRCACT(1)) D  ; need to create new activity
"RTN","GMRCIAC2",83,0)
 . M FDA(1,123.02,"+1,"_GMRCO_",")=GMRCFDA
"RTN","GMRCIAC2",84,0)
 . D UPDATE^DIE("","FDA(1)","GMRCACT","GMRCERR")
"RTN","GMRCIAC2",85,0)
 K GMRCFDA,FDA
"RTN","GMRCIAC2",86,0)
 D  ; file comments if present
"RTN","GMRCIAC2",87,0)
 . I $D(^TMP("GMRCFIL",$J,"OBX",3)) D  ; general comments
"RTN","GMRCIAC2",88,0)
 .. N TMPARR
"RTN","GMRCIAC2",89,0)
 .. S TMPARR=$NA(^TMP("GMRCFIL",$J,"OBX",3))
"RTN","GMRCIAC2",90,0)
 .. D TRIMWP^GMRCIUTL(TMPARR,5)
"RTN","GMRCIAC2",91,0)
 .. D WP^DIE(123.02,GMRCACT(1)_","_GMRCO_",",5,"K",TMPARR)
"RTN","GMRCIAC2",92,0)
 . I $D(^TMP("GMRCFIL",$J,"NTE")) D  ; DC or cancel comments
"RTN","GMRCIAC2",93,0)
 .. N TMPARR
"RTN","GMRCIAC2",94,0)
 .. S TMPARR=$NA(^TMP("GMRCFIL",$J,"NTE"))
"RTN","GMRCIAC2",95,0)
 .. D TRIMWP^GMRCIUTL(TMPARR,3)
"RTN","GMRCIAC2",96,0)
 .. D WP^DIE(123.02,GMRCACT(1)_","_GMRCO_",",5,"K",TMPARR)
"RTN","GMRCIAC2",97,0)
 .. Q
"RTN","GMRCIAC2",98,0)
 D  ; update order if necessary
"RTN","GMRCIAC2",99,0)
 . I $P($G(^GMR(123,GMRCO,12)),U,5)="F" Q  ; fillers have no order
"RTN","GMRCIAC2",100,0)
 . I GMRCLAST=11!(GMRCLAST=13)!(GMRCLAST=14) Q  ;no status chg
"RTN","GMRCIAC2",101,0)
 . I GMRCLAST=4!(GMRCLAST=20) Q  ;no status chg
"RTN","GMRCIAC2",102,0)
 . D UPDORD(GMRCO,GMRCACT(1))
"RTN","GMRCIAC2",103,0)
 K ^TMP("GMRCFIL",$J)
"RTN","GMRCIAC2",104,0)
 Q
"RTN","GMRCIAC2",105,0)
 ;
"RTN","GMRCIAC2",106,0)
TST(ARRAY) ;process test message and check item ordered
"RTN","GMRCIAC2",107,0)
 ;Input:
"RTN","GMRCIAC2",108,0)
 ; ARRAY  = name of array containing message parts
"RTN","GMRCIAC2",109,0)
 ;
"RTN","GMRCIAC2",110,0)
 N GMRCFDA,GMRCORC,GMRCDA,GMRCITM,GMRCITER
"RTN","GMRCIAC2",111,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIAC2",112,0)
 M ^TMP("GMRCIN",$J)=@ARRAY
"RTN","GMRCIAC2",113,0)
 D  ;get ordered item and service
"RTN","GMRCIAC2",114,0)
 . S GMRCITM=$P(^TMP("GMRCIN",$J,"OBR"),"|",4)
"RTN","GMRCIAC2",115,0)
 . I GMRCITM["VA1233" D  ; proc
"RTN","GMRCIAC2",116,0)
 .. N PROC
"RTN","GMRCIAC2",117,0)
 .. S PROC=$$GETPROC^GMRCIUTL(GMRCITM)
"RTN","GMRCIAC2",118,0)
 .. I +PROC'>0!('$P(PROC,U,2)) S GMRCITER=$P(PROC,U,3) Q
"RTN","GMRCIAC2",119,0)
 . I GMRCITM["VA1235" D
"RTN","GMRCIAC2",120,0)
 .. N SERV
"RTN","GMRCIAC2",121,0)
 .. S SERV=$$GETSERV^GMRCIUTL(GMRCITM) ;consult
"RTN","GMRCIAC2",122,0)
 .. I +SERV'>0 S GMRCITER=$P(SERV,U,3)
"RTN","GMRCIAC2",123,0)
 I $D(GMRCITER) D  ;error in procedure or service, reject new order
"RTN","GMRCIAC2",124,0)
 . N GMRCRSLT
"RTN","GMRCIAC2",125,0)
 . D RESP^GMRCIUTL("AR",HL("MID"),,,GMRCITER) ;build HLA(
"RTN","GMRCIAC2",126,0)
 . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
"RTN","GMRCIAC2",127,0)
 I '$D(GMRCITER) D
"RTN","GMRCIAC2",128,0)
 . N GMRCRSLT
"RTN","GMRCIAC2",129,0)
 . D RESP^GMRCIUTL("AA",HL("MID")) ;build HLA(
"RTN","GMRCIAC2",130,0)
 . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
"RTN","GMRCIAC2",131,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIAC2",132,0)
 Q
"RTN","GMRCIAC2",133,0)
 ;
"RTN","GMRCIAC2",134,0)
GETDA(GMRCORC) ; determine what local Consult ien to work on
"RTN","GMRCIAC2",135,0)
 ; Input:
"RTN","GMRCIAC2",136,0)
 ;  GMRCORC = ORC seg from incoming message
"RTN","GMRCIAC2",137,0)
 ; Output:
"RTN","GMRCIAC2",138,0)
 ;  ien from file 123
"RTN","GMRCIAC2",139,0)
 ;
"RTN","GMRCIAC2",140,0)
 N GMRCORC2,GMRCORC3
"RTN","GMRCIAC2",141,0)
 S GMRCORC2=$P(GMRCORC,"|",2),GMRCORC3=$P(GMRCORC,"|",3)
"RTN","GMRCIAC2",142,0)
 I $$IEN^XUAF4($P(GMRCORC2,U,2))=$$KSP^XUPARAM("INST") Q +GMRCORC2
"RTN","GMRCIAC2",143,0)
 Q +GMRCORC3
"RTN","GMRCIAC2",144,0)
 ;
"RTN","GMRCIAC2",145,0)
DUPACT(GMRCO,ACTVT,ORC,OBX) ;check to see if activity is a dup transmission
"RTN","GMRCIAC2",146,0)
 ;Input:
"RTN","GMRCIAC2",147,0)
 ;  GMRCO = ien of consult
"RTN","GMRCIAC2",148,0)
 ;  ACTVT = ien of activity from file 123.1
"RTN","GMRCIAC2",149,0)
 ;  ORC   = ORC segment from message
"RTN","GMRCIAC2",150,0)
 ;  OBX   = OBX segment containing result
"RTN","GMRCIAC2",151,0)
 ;
"RTN","GMRCIAC2",152,0)
 ;Output:
"RTN","GMRCIAC2",153,0)
 ;  0  = activity is not a duplicate of one on file already
"RTN","GMRCIAC2",154,0)
 ;  1  = duplicate, activity already on file
"RTN","GMRCIAC2",155,0)
 ;
"RTN","GMRCIAC2",156,0)
 N GMRCIADT,GMRCIFDT,DUP
"RTN","GMRCIAC2",157,0)
 S GMRCIFDT=+$$HL7TFM^XLFDT($P(ORC,"|",9))
"RTN","GMRCIAC2",158,0)
 S GMRCIADT=+$$HL7TFM^XLFDT($P(ORC,"|",15))
"RTN","GMRCIAC2",159,0)
 S DUP=0
"RTN","GMRCIAC2",160,0)
 I $D(^GMR(123,GMRCO,40,"AC",ACTVT,GMRCIFDT,GMRCIADT)) D  Q DUP ;dupl.
"RTN","GMRCIAC2",161,0)
 . N RSLT,RFIL,RSITE,ROOT
"RTN","GMRCIAC2",162,0)
 . I $L($G(OBX)) D  Q:'$G(DUP)
"RTN","GMRCIAC2",163,0)
 .. S RFIL=$P($P(OBX,"|",3),U,3),RFIL=$P(RFIL,"VA",2)
"RTN","GMRCIAC2",164,0)
 .. S RSLT=+$P(OBX,"|",5)
"RTN","GMRCIAC2",165,0)
 .. S RSITE=$$IEN^XUAF4($P($P(OBX,"|",5),U,3))
"RTN","GMRCIAC2",166,0)
 .. S ROOT=$S($P($P(OBX,"|",3),U,2)["TIU":"TIU(",1:"MCAR(")
"RTN","GMRCIAC2",167,0)
 .. S RSLT=RSLT_";"_ROOT_RFIL
"RTN","GMRCIAC2",168,0)
 .. I ACTVT=12,$D(^GMR(123,GMRCO,51,"AR",RSLT,RSITE)) Q  ;no dup
"RTN","GMRCIAC2",169,0)
 .. I ACTVT'=12,'$D(^GMR(123,GMRCO,51,"AR",RSLT,RSITE)) Q  ;no dup
"RTN","GMRCIAC2",170,0)
 .. S DUP=1
"RTN","GMRCIAC2",171,0)
 . S DUP=1
"RTN","GMRCIAC2",172,0)
 . D APPACK(GMRCO,"AR",802) ;send app. ACK and unlock record
"RTN","GMRCIAC2",173,0)
 Q 0
"RTN","GMRCIAC2",174,0)
 ;
"RTN","GMRCIAC2",175,0)
APPACK(GMRCO,ACK,ERR) ;send application acknowledgement for all cases
"RTN","GMRCIAC2",176,0)
 ;Input:
"RTN","GMRCIAC2",177,0)
 ;  GMRCO = ien from file 123
"RTN","GMRCIAC2",178,0)
 ;  ACK   = ACK code to include  ("AA"=accept or "AR"=reject)
"RTN","GMRCIAC2",179,0)
 ;  ERR   = error code to return if there is one (optional)
"RTN","GMRCIAC2",180,0)
 ;
"RTN","GMRCIAC2",181,0)
 ; Output: none
"RTN","GMRCIAC2",182,0)
 ;
"RTN","GMRCIAC2",183,0)
 ;send appl ACK
"RTN","GMRCIAC2",184,0)
 N GMRCRSLT
"RTN","GMRCIAC2",185,0)
 I '$G(ERR) S ERR=""
"RTN","GMRCIAC2",186,0)
 D RESP^GMRCIUTL(ACK,HL("MID"),,,ERR) ;build HLA("HLA", array
"RTN","GMRCIAC2",187,0)
 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
"RTN","GMRCIAC2",188,0)
 ;
"RTN","GMRCIAC2",189,0)
 D UNLKREC^GMRCUTL1(GMRCO) ;unlock record
"RTN","GMRCIAC2",190,0)
 Q
"RTN","GMRCIACT")
0^6^B61170306
"RTN","GMRCIACT",1,0)
GMRCIACT ;SLC/JFR - PROCESS ACTIONS ON IFC ;08/16/10  08:46
"RTN","GMRCIACT",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**22,47,58,66**;DEC 27, 1997;Build 30
"RTN","GMRCIACT",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","GMRCIACT",4,0)
 ;#2051($$FIND1^DIC), #2053(DIE), #2165 HLMA1, #2701 MPIF001, #10103 XLFDT, #3065 XLFNAME, #2171 XUAF4
"RTN","GMRCIACT",5,0)
 Q  ;don't start here!
"RTN","GMRCIACT",6,0)
NW(ARRAY) ;process and file new order
"RTN","GMRCIACT",7,0)
 ;Input:
"RTN","GMRCIACT",8,0)
 ; ARRAY  = name of array containing message parts
"RTN","GMRCIACT",9,0)
 ;
"RTN","GMRCIACT",10,0)
 N GMRCFDA,GMRCORC,GMRCDA,GMRCITM,GMRCITER,GMRCROUT,GMRCFCN,GMRCLAC
"RTN","GMRCIACT",11,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIACT",12,0)
 M ^TMP("GMRCIN",$J)=@ARRAY
"RTN","GMRCIACT",13,0)
 S GMRCORC=^TMP("GMRCIN",$J,"ORC")
"RTN","GMRCIACT",14,0)
 D  I $D(GMRCITER) Q  ;Check for order already being on file
"RTN","GMRCIACT",15,0)
 . S GMRCFCN=+$P(GMRCORC,"|",2)
"RTN","GMRCIACT",16,0)
 . S GMRCROUT=$$IEN^XUAF4($P($P(GMRCORC,"|",2),U,2))
"RTN","GMRCIACT",17,0)
 . I '$O(^GMR(123,"AIFC",GMRCROUT,GMRCFCN,0)) Q  ;no dup
"RTN","GMRCIACT",18,0)
 . S GMRCITER=802
"RTN","GMRCIACT",19,0)
 . D APPACK^GMRCIAC2(0,"AR",GMRCITER) ;send app. ack w/ error
"RTN","GMRCIACT",20,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIACT",21,0)
 I '$D(^TMP("GMRCIN",$J,"PID")) Q  ;prepare reject message (no PID)
"RTN","GMRCIACT",22,0)
 D  ;get patient DFN from ICN in message
"RTN","GMRCIACT",23,0)
 . N PAT
"RTN","GMRCIACT",24,0)
 . S PAT=$$GETDFN^MPIF001(+$P(^TMP("GMRCIN",$J,"PID"),"|",2))
"RTN","GMRCIACT",25,0)
 . I +PAT'>1 S GMRCFDA(.02)="" Q
"RTN","GMRCIACT",26,0)
 . S GMRCFDA(.02)=+PAT
"RTN","GMRCIACT",27,0)
 I '$G(GMRCFDA(.02)) D  Q  ;reject message, patient is unknown
"RTN","GMRCIACT",28,0)
 . N STA S STA=$P($P(^TMP("GMRCIN",$J,"ORC"),"|",2),U,2)
"RTN","GMRCIACT",29,0)
 . N OBR S OBR=^TMP("GMRCIN",$J,"OBR")
"RTN","GMRCIACT",30,0)
 . D PTERRMSG^GMRCIERR(^TMP("GMRCIN",$J,"PID"),STA,,OBR)
"RTN","GMRCIACT",31,0)
 . D APPACK^GMRCIAC2(0,"AR",201) ; send app. ack w/error
"RTN","GMRCIACT",32,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIACT",33,0)
 D  ;get ordered item and service
"RTN","GMRCIACT",34,0)
 . S GMRCITM=$P(^TMP("GMRCIN",$J,"OBR"),"|",4)
"RTN","GMRCIACT",35,0)
 . I GMRCITM["VA1233" D  ; proc
"RTN","GMRCIACT",36,0)
 .. N PROC
"RTN","GMRCIACT",37,0)
 .. S PROC=$$GETPROC^GMRCIUTL(GMRCITM)
"RTN","GMRCIACT",38,0)
 .. I +PROC'>0!('$P(PROC,U,2)) S GMRCITER=$P(PROC,U,3) Q
"RTN","GMRCIACT",39,0)
 .. S GMRCFDA(4)=$P(PROC,U)_";GMR(123.3,"
"RTN","GMRCIACT",40,0)
 .. S GMRCFDA(1)=$P(PROC,U,2)
"RTN","GMRCIACT",41,0)
 . I GMRCITM["VA1235" D
"RTN","GMRCIACT",42,0)
 .. N SERV
"RTN","GMRCIACT",43,0)
 .. S SERV=$$GETSERV^GMRCIUTL(GMRCITM) ;consult
"RTN","GMRCIACT",44,0)
 .. I +SERV'>0 S GMRCITER=$P(SERV,U,3)
"RTN","GMRCIACT",45,0)
 .. S GMRCFDA(1)=SERV
"RTN","GMRCIACT",46,0)
 I $D(GMRCITER) D  Q  ;error in procedure or service, reject new order
"RTN","GMRCIACT",47,0)
 . D APPACK^GMRCIAC2(0,"AR",GMRCITER) ; send app. ACK
"RTN","GMRCIACT",48,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIACT",49,0)
 ;
"RTN","GMRCIACT",50,0)
 S GMRCFDA(.01)=$$NOW^XLFDT
"RTN","GMRCIACT",51,0)
 S GMRCFDA(3)=$$HL7TFM^XLFDT($P(GMRCORC,"|",15))
"RTN","GMRCIACT",52,0)
 S GMRCFDA(6)=$$FIND1^DIC(101,"","X","GMRCPLACE - ON CALL")
"RTN","GMRCIACT",53,0)
 S GMRCFDA(17)=$$HL7TFM^XLFDT($P($P(GMRCORC,"|",7),U,4)) ;WAT/66 Earliest Date
"RTN","GMRCIACT",54,0)
 D  ;get urgency to file
"RTN","GMRCIACT",55,0)
 . N URG
"RTN","GMRCIACT",56,0)
 . S URG=$$URG^GMRCHL7A($P($P(GMRCORC,"|",7),U,6))
"RTN","GMRCIACT",57,0)
 . S GMRCFDA(5)=$$FIND1^DIC(101,"","X","GMRCURGENCY - "_URG)
"RTN","GMRCIACT",58,0)
 S GMRCFDA(8)=5
"RTN","GMRCIACT",59,0)
 S GMRCFDA(9)=$S($P(GMRCORC,"|",16)["FI":24,1:23),GMRCLAC=GMRCFDA(9)
"RTN","GMRCIACT",60,0)
 S GMRCFDA(14)=$P(^TMP("GMRCIN",$J,"OBR"),"|",18)
"RTN","GMRCIACT",61,0)
 S GMRCFDA(.05)=$$IEN^XUAF4(+$P(GMRCORC,"|",17))
"RTN","GMRCIACT",62,0)
 S GMRCFDA(.06)=GMRCFCN
"RTN","GMRCIACT",63,0)
 S GMRCFDA(.07)=GMRCROUT
"RTN","GMRCIACT",64,0)
 D  ;get and set ordering prov info & entering person info
"RTN","GMRCIACT",65,0)
 . N GMRCOP
"RTN","GMRCIACT",66,0)
 . S GMRCOP=$$FMNAME^XLFNAME($P(GMRCORC,"|",12))
"RTN","GMRCIACT",67,0)
 . Q:'$L(GMRCOP)
"RTN","GMRCIACT",68,0)
 . S GMRCFDA(.126)=GMRCOP
"RTN","GMRCIACT",69,0)
 . Q
"RTN","GMRCIACT",70,0)
 S GMRCFDA(.125)="F"
"RTN","GMRCIACT",71,0)
 I $L($P(GMRCORC,"|",14)) D
"RTN","GMRCIACT",72,0)
 . N GMRCP14 S GMRCP14=$P(GMRCORC,"|",14)
"RTN","GMRCIACT",73,0)
 . S GMRCFDA(.132)=$P(GMRCP14,"B") ; requestor's phone number
"RTN","GMRCIACT",74,0)
 . S GMRCFDA(.133)=$P(GMRCP14,"B",2) ; requestor's dig pager
"RTN","GMRCIACT",75,0)
 S GMRCFDA(13)=$S($D(GMRCFDA(4)):"P",1:"C")
"RTN","GMRCIACT",76,0)
 I $D(^TMP("GMRCIN",$J,"OBX",2)) D
"RTN","GMRCIACT",77,0)
 . S GMRCFDA(30)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U,2)
"RTN","GMRCIACT",78,0)
 . S GMRCFDA(30.1)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U)
"RTN","GMRCIACT",79,0)
 M FDA(1,123,"+1,")=GMRCFDA
"RTN","GMRCIACT",80,0)
 D UPDATE^DIE("","FDA(1)","GMRCDA","GMRCERR")
"RTN","GMRCIACT",81,0)
 I '$D(GMRCDA) D  Q  ;couldn't get new consult #
"RTN","GMRCIACT",82,0)
 . D APPACK^GMRCIAC2(0,"AR",901) ; send app. ACK
"RTN","GMRCIACT",83,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIACT",84,0)
 K GMRCFDA,FDA
"RTN","GMRCIACT",85,0)
 D  ; file reason for request
"RTN","GMRCIACT",86,0)
 . D TRIMWP^GMRCIUTL($NA(^TMP("GMRCIN",$J,"OBX",1)),5)
"RTN","GMRCIACT",87,0)
 . D WP^DIE(123,GMRCDA(1)_",",20,"K",$NA(^TMP("GMRCIN",$J,"OBX",1)))
"RTN","GMRCIACT",88,0)
 . Q
"RTN","GMRCIACT",89,0)
 D  ;file activity tracking
"RTN","GMRCIACT",90,0)
 . N GMRCSEG
"RTN","GMRCIACT",91,0)
 . S GMRCSEG("ORC")=GMRCORC
"RTN","GMRCIACT",92,0)
 . S GMRCSEG("OBX",5,1)=^TMP("GMRCIN",$J,"OBX",5,1)
"RTN","GMRCIACT",93,0)
 . D FILEACT^GMRCIAC2(GMRCDA(1),GMRCLAC,,"GMRCSEG")
"RTN","GMRCIACT",94,0)
 D  ;print SF-513
"RTN","GMRCIACT",95,0)
 . I GMRCLAC=24 Q  ;don't print if part of a FWD to IFC
"RTN","GMRCIACT",96,0)
 . D PRNT^GMRCUTL1("",GMRCDA(1))
"RTN","GMRCIACT",97,0)
 D  ;send notifications
"RTN","GMRCIACT",98,0)
 . I GMRCLAC=24 Q  ;no alerts yet if part of FWD to IFC
"RTN","GMRCIACT",99,0)
 . N GMRCORTX
"RTN","GMRCIACT",100,0)
 . S GMRCORTX="New remotely ordered consult "_$$ORTX^GMRCAU(+GMRCDA(1))
"RTN","GMRCIACT",101,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA(1),0),U,2),GMRCORTX,GMRCDA(1),27,,1)
"RTN","GMRCIACT",102,0)
 D  ;send appl ack :-(
"RTN","GMRCIACT",103,0)
 . N GMRCRSLT
"RTN","GMRCIACT",104,0)
 . D RESP^GMRCIUTL("AA",HL("MID"),$P(GMRCORC,"|"),GMRCDA(1))
"RTN","GMRCIACT",105,0)
 . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
"RTN","GMRCIACT",106,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIACT",107,0)
 Q
"RTN","GMRCIACT",108,0)
 ;
"RTN","GMRCIACT",109,0)
DIS(GMRCAR) ;dis-associate a result from a remote request
"RTN","GMRCIACT",110,0)
 ;Input:
"RTN","GMRCIACT",111,0)
 ; GMRCAR = array name containing message
"RTN","GMRCIACT",112,0)
 ;      e.g.  ^TMP("GMRCIF",$J)
"RTN","GMRCIACT",113,0)
 N GMRCDA,GMRCFDA,FDA,GMRCERR,GMRCORC
"RTN","GMRCIACT",114,0)
 M ^TMP("GMRCID",$J)=@GMRCAR
"RTN","GMRCIACT",115,0)
 S GMRCORC=^TMP("GMRCID",$J,"ORC")
"RTN","GMRCIACT",116,0)
 S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
"RTN","GMRCIACT",117,0)
 I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
"RTN","GMRCIACT",118,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AR",901) ;send app. ACK
"RTN","GMRCIACT",119,0)
 . K ^TMP("GMRCID",$J) Q
"RTN","GMRCIACT",120,0)
 ;    v--check to see if a dup transmission
"RTN","GMRCIACT",121,0)
 I $$DUPACT^GMRCIAC2(GMRCDA,12,GMRCORC,^TMP("GMRCID",$J,"OBX",4,1)) Q
"RTN","GMRCIACT",122,0)
 ;
"RTN","GMRCIACT",123,0)
 D FILEACT^GMRCIAC2(GMRCDA,12,,$NA(^TMP("GMRCID",$J))) ; act. tracking
"RTN","GMRCIACT",124,0)
 D FILRES^GMRCIAC2(GMRCDA,^TMP("GMRCID",$J,"OBX",4,1)) ;file results
"RTN","GMRCIACT",125,0)
 K GMRCERR,FDA,GMRCFDA
"RTN","GMRCIACT",126,0)
 I $$STSCHG^GMRCDIS(GMRCDA) S FDA(1,123,GMRCDA_",",8)=6
"RTN","GMRCIACT",127,0)
 S FDA(1,123,GMRCDA_",",9)=12
"RTN","GMRCIACT",128,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and status
"RTN","GMRCIACT",129,0)
 D  ;send notifications
"RTN","GMRCIACT",130,0)
 . I $P(^GMR(123,GMRCDA,12),U,5)="F" Q  ;DIS from placer before IFC
"RTN","GMRCIACT",131,0)
 . N GMRCORTX
"RTN","GMRCIACT",132,0)
 . S GMRCORTX="Remote result removed from "_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIACT",133,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,63,,1)
"RTN","GMRCIACT",134,0)
 D  ;send appl ACK
"RTN","GMRCIACT",135,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AA") ; send app. ACK and unlock record
"RTN","GMRCIACT",136,0)
 K ^TMP("GMRCID",$J)
"RTN","GMRCIACT",137,0)
 Q
"RTN","GMRCIACT",138,0)
 ;
"RTN","GMRCIACT",139,0)
OTHER(GMRCAR) ;process most IFC actions
"RTN","GMRCIACT",140,0)
 ;will process the receive, schedule, DC, cancel and added comment action
"RTN","GMRCIACT",141,0)
 ;
"RTN","GMRCIACT",142,0)
 ;Input:
"RTN","GMRCIACT",143,0)
 ; GMRCAR = array name containing message
"RTN","GMRCIACT",144,0)
 ;      e.g.  ^TMP("GMRCIF",$J)
"RTN","GMRCIACT",145,0)
 ;
"RTN","GMRCIACT",146,0)
 N GMRCDA,GMRCFDA,GMRCORC,GMRCLAT,GMRCACT,GMRCROL,FDA
"RTN","GMRCIACT",147,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIACT",148,0)
 M ^TMP("GMRCIN",$J)=@GMRCAR
"RTN","GMRCIACT",149,0)
 ;
"RTN","GMRCIACT",150,0)
 S GMRCORC=^TMP("GMRCIN",$J,"ORC")
"RTN","GMRCIACT",151,0)
 S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)  ;get ien to work on
"RTN","GMRCIACT",152,0)
 S GMRCROL=$P(^GMR(123,GMRCDA,12),U,5)
"RTN","GMRCIACT",153,0)
 I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
"RTN","GMRCIACT",154,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AR",901) ; send app. ACK
"RTN","GMRCIACT",155,0)
 . K ^TMP("GMRCIN",$J) Q
"RTN","GMRCIACT",156,0)
 ;
"RTN","GMRCIACT",157,0)
 I $P(GMRCORC,"|")'="IP" D  ; status update
"RTN","GMRCIACT",158,0)
 . N GMRCOS S GMRCOS=$P(GMRCORC,"|",5)
"RTN","GMRCIACT",159,0)
 . S GMRCFDA(8)=$S(GMRCOS="IP":6,GMRCOS="SC":8,GMRCOS="CA":13,1:1)
"RTN","GMRCIACT",160,0)
 . ; IP=receive, SC=schedule, CA=cancel, DC=discontinue
"RTN","GMRCIACT",161,0)
 D  ; get last action taken
"RTN","GMRCIACT",162,0)
 . I '$G(GMRCFDA(8)) S (GMRCFDA(9),GMRCLAT)=20 Q
"RTN","GMRCIACT",163,0)
 . I GMRCFDA(8)=6 S (GMRCFDA(9),GMRCLAT)=21 Q
"RTN","GMRCIACT",164,0)
 . I GMRCFDA(8)=8 S (GMRCFDA(9),GMRCLAT)=8 Q
"RTN","GMRCIACT",165,0)
 . I GMRCFDA(8)=1 S (GMRCFDA(9),GMRCLAT)=6 Q
"RTN","GMRCIACT",166,0)
 . I GMRCFDA(8)=13 S (GMRCFDA(9),GMRCLAT)=19 Q
"RTN","GMRCIACT",167,0)
 ;                         ^--last action taken
"RTN","GMRCIACT",168,0)
 ;    v-- check to see if a dup transmission
"RTN","GMRCIACT",169,0)
 I $$DUPACT^GMRCIAC2(GMRCDA,GMRCLAT,GMRCORC) Q
"RTN","GMRCIACT",170,0)
 ;
"RTN","GMRCIACT",171,0)
 M FDA(1,123,GMRCDA_",")=GMRCFDA
"RTN","GMRCIACT",172,0)
 D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and update status
"RTN","GMRCIACT",173,0)
 K GMRCFDA
"RTN","GMRCIACT",174,0)
 D FILEACT^GMRCIAC2(GMRCDA,GMRCLAT,,$NA(^TMP("GMRCIN",$J)))
"RTN","GMRCIACT",175,0)
 D  ;send notifications
"RTN","GMRCIACT",176,0)
 . N GMRCTX,GMRCNOT,GMRCFL
"RTN","GMRCIACT",177,0)
 . S GMRCFL=1
"RTN","GMRCIACT",178,0)
 . I GMRCLAT=20!(GMRCLAT=8)!(GMRCLAT=21) D
"RTN","GMRCIACT",179,0)
 .. I GMRCLAT=20 D  I '$D(GMRCTX) Q
"RTN","GMRCIACT",180,0)
 ... I $P(^GMR(123,GMRCDA,40,1,0),U,2)'=24 D  Q
"RTN","GMRCIACT",181,0)
 .... S GMRCTX="Comment Added to remote"
"RTN","GMRCIACT",182,0)
 ... N ACT S ACT=1
"RTN","GMRCIACT",183,0)
 ... F  S ACT=$O(^GMR(123,GMRCDA,40,ACT)) Q:'ACT!($D(GMRCTX))  D
"RTN","GMRCIACT",184,0)
 .... I $P(^GMR(123,GMRCDA,40,ACT,0),U,2)=25,$O(^GMR(123,GMRCDA,40,ACT)) D
"RTN","GMRCIACT",185,0)
 ..... S GMRCTX="Comment Added to remote"
"RTN","GMRCIACT",186,0)
 .. I '$D(GMRCTX),GMRCROL="F" Q  ;sch & rec on filler part of FWD 2 IFC
"RTN","GMRCIACT",187,0)
 .. I GMRCLAT=8 S GMRCTX="Scheduled remote"
"RTN","GMRCIACT",188,0)
 .. I GMRCLAT=21 S GMRCTX="Received remote"
"RTN","GMRCIACT",189,0)
 .. S GMRCTX=GMRCTX_" Consult: "_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIACT",190,0)
 .. S GMRCNOT=63
"RTN","GMRCIACT",191,0)
 . I GMRCLAT=6 D
"RTN","GMRCIACT",192,0)
 .. S GMRCFL=$$DCNOTE^GMRCADC(GMRCDA,.5)
"RTN","GMRCIACT",193,0)
 .. S GMRCTX="Discontinued remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIACT",194,0)
 .. S GMRCNOT=23
"RTN","GMRCIACT",195,0)
 . I GMRCLAT=19 D
"RTN","GMRCIACT",196,0)
 .. I GMRCROL="F" Q  ;canc on a filler is part of FWD 2 IFC
"RTN","GMRCIACT",197,0)
 .. S GMRCTX="Cancelled remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
"RTN","GMRCIACT",198,0)
 .. S GMRCNOT=30
"RTN","GMRCIACT",199,0)
 . I '$D(GMRCNOT) Q  ;don't send any alerts
"RTN","GMRCIACT",200,0)
 . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCTX,GMRCDA,GMRCNOT,,GMRCFL)
"RTN","GMRCIACT",201,0)
 ;
"RTN","GMRCIACT",202,0)
 D  ;send appl ACK
"RTN","GMRCIACT",203,0)
 . D APPACK^GMRCIAC2(GMRCDA,"AA") ;send app. ACK and unlock record
"RTN","GMRCIACT",204,0)
 K ^TMP("GMRCIN",$J)
"RTN","GMRCIACT",205,0)
 Q
"RTN","GMRCIACT",206,0)
 ;
"RTN","GMRCISEG")
0^7^B31263657
"RTN","GMRCISEG",1,0)
GMRCISEG ;SLC/JFR - CREATE IFC HL7 SEGMENTS ;08/16/10  08:30
"RTN","GMRCISEG",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**22,66**;DEC 27, 1997;Build 30
"RTN","GMRCISEG",3,0)
 ;   $$GET1^DIQ          ORC+28,ORC+29,OBXTZ+11
"RTN","GMRCISEG",4,0)
 ;#2171 XUAF4, #10103 XLFDT, #10106 HLFNC, #3042 MCAPI, #10112 VASITE, #2541 $$KSP^XUPARAM
"RTN","GMRCISEG",5,0)
 ;
"RTN","GMRCISEG",6,0)
 Q  ;don't enter at top
"RTN","GMRCISEG",7,0)
BUILD(SEG,PCS) ;create any segment from array in PCS using |^&/~
"RTN","GMRCISEG",8,0)
 ; SEG = ORC,OBR,etc.
"RTN","GMRCISEG",9,0)
 ; PCS = array of data elements to be combined into the segement
"RTN","GMRCISEG",10,0)
 ;       array is numbered by the "|" piece
"RTN","GMRCISEG",11,0)
 N ARR,SEGMNT
"RTN","GMRCISEG",12,0)
 S ARR=0,SEGMNT=""
"RTN","GMRCISEG",13,0)
 F  S ARR=$O(PCS(ARR)) Q:'ARR  D
"RTN","GMRCISEG",14,0)
 . S $P(SEGMNT,"|",ARR)=PCS(ARR)
"RTN","GMRCISEG",15,0)
 . Q
"RTN","GMRCISEG",16,0)
 Q SEG_"|"_SEGMNT
"RTN","GMRCISEG",17,0)
ORC(GMRCO,GMRCOC,GMRCOS,GMRCACT)    ;build ORC for all but new orders
"RTN","GMRCISEG",18,0)
 ;Input:
"RTN","GMRCISEG",19,0)
 ; GMRCO = ien from file 123
"RTN","GMRCISEG",20,0)
 ; GMRCOC = order control
"RTN","GMRCISEG",21,0)
 ; GMRCOS = order status
"RTN","GMRCISEG",22,0)
 ; GMRCACT = ien in 40 multiple of particular action
"RTN","GMRCISEG",23,0)
 ;
"RTN","GMRCISEG",24,0)
 ;Output:
"RTN","GMRCISEG",25,0)
 ; ORC segment
"RTN","GMRCISEG",26,0)
 ;
"RTN","GMRCISEG",27,0)
 I '$D(GMRCO)!('$D(GMRCOC))!('$D(GMRCACT)) Q "ERROR"
"RTN","GMRCISEG",28,0)
 N GMRCPCS,SITE,GMRCRP
"RTN","GMRCISEG",29,0)
 S GMRCPCS(1)=GMRCOC
"RTN","GMRCISEG",30,0)
 I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D
"RTN","GMRCISEG",31,0)
 . S GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFR"
"RTN","GMRCISEG",32,0)
 . S GMRCPCS(3)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
"RTN","GMRCISEG",33,0)
 . S GMRCPCS(3)=GMRCPCS(3)_"^GMRCIFC"
"RTN","GMRCISEG",34,0)
 I $P($G(^GMR(123,GMRCO,12)),U,5)="F" D
"RTN","GMRCISEG",35,0)
 . S GMRCPCS(2)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
"RTN","GMRCISEG",36,0)
 . S GMRCPCS(2)=GMRCPCS(2)_"^GMRCIFR"
"RTN","GMRCISEG",37,0)
 . S GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFC"
"RTN","GMRCISEG",38,0)
 S GMRCPCS(5)=$S($D(GMRCOS):GMRCOS,1:"")
"RTN","GMRCISEG",39,0)
 I GMRCOC["X" D
"RTN","GMRCISEG",40,0)
 .S $P(GMRCPCS(7),U,4)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,24)) ;wat/66
"RTN","GMRCISEG",41,0)
 .S $P(GMRCPCS(7),U,6)=$$URG^GMRCIUTL(GMRCO)
"RTN","GMRCISEG",42,0)
 S GMRCPCS(9)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,40,GMRCACT,0),U,1))
"RTN","GMRCISEG",43,0)
 S GMRCPCS(10)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,40,GMRCACT,0),U,5))
"RTN","GMRCISEG",44,0)
 S GMRCRP=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,4) I +GMRCRP D
"RTN","GMRCISEG",45,0)
 . S GMRCPCS(12)=$$HLNAME^GMRCIUTL(GMRCRP)
"RTN","GMRCISEG",46,0)
 . N GMRCPHN,GMRCPAG
"RTN","GMRCISEG",47,0)
 . S GMRCPHN=$$GET1^DIQ(200,GMRCRP,.132)
"RTN","GMRCISEG",48,0)
 . S GMRCPAG=$$GET1^DIQ(200,GMRCRP,.138)
"RTN","GMRCISEG",49,0)
 . S GMRCPCS(14)=$$HLPHONE^HLFNC(GMRCPHN,GMRCPAG)
"RTN","GMRCISEG",50,0)
 S GMRCPCS(15)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,40,GMRCACT,0),U,3))
"RTN","GMRCISEG",51,0)
 I GMRCOC["X"!(GMRCOC="SC")!(GMRCOC="RE") D
"RTN","GMRCISEG",52,0)
 . I GMRCOC="XX" D  Q
"RTN","GMRCISEG",53,0)
 .. I $P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=25 D  Q
"RTN","GMRCISEG",54,0)
 ... S GMRCPCS(16)="FI^FORWARD TO IFC^99GMRC"
"RTN","GMRCISEG",55,0)
 .. S GMRCPCS(16)="F^FORWARD^99GMRC"
"RTN","GMRCISEG",56,0)
 . I GMRCOC="XO" S GMRCPCS(16)="E^EDIT-RESUBMIT^99GMRC" Q
"RTN","GMRCISEG",57,0)
 . I GMRCOC="SC" D  Q
"RTN","GMRCISEG",58,0)
 .. I GMRCOS="IP" S GMRCPCS(16)="R^RECEIVE^99GMRC"
"RTN","GMRCISEG",59,0)
 .. I GMRCOS="SC"  S GMRCPCS(16)="SC^SCHEDULE^99GMRC"
"RTN","GMRCISEG",60,0)
 . I GMRCOC="RE" D
"RTN","GMRCISEG",61,0)
 .. N ACTVT S ACTVT=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
"RTN","GMRCISEG",62,0)
 .. I ACTVT=12 S GMRCPCS(16)="D^DISASSOCIATE RESULT^99GMRC"
"RTN","GMRCISEG",63,0)
 .. I ACTVT=13 S GMRCPCS(16)="A^ADDENDUM^99GMRC"
"RTN","GMRCISEG",64,0)
 .. I ACTVT=4 S GMRCPCS(16)="S^SIGNIFICANT FINDING^99GMRC"
"RTN","GMRCISEG",65,0)
 . Q
"RTN","GMRCISEG",66,0)
 S SITE=$$SITE^VASITE
"RTN","GMRCISEG",67,0)
 I +SITE S GMRCPCS(17)=$P(SITE,U,3)_U_$P(SITE,U,2) ;use loc instead? ;-(
"RTN","GMRCISEG",68,0)
 Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
"RTN","GMRCISEG",69,0)
 ;
"RTN","GMRCISEG",70,0)
OBXWP(GMRCO,GMRCOC,GMRCACT,GMRCSEG) ; return a WP field in OBX segs
"RTN","GMRCISEG",71,0)
 ; Input:
"RTN","GMRCISEG",72,0)
 ;  GMRCO   =
"RTN","GMRCISEG",73,0)
 ;  GMRCOC  =
"RTN","GMRCISEG",74,0)
 ;  GMRCACT = activity in 40 mult triggering msg
"RTN","GMRCISEG",75,0)
 ;  GMRCSEG = GLOBAL array to return results in
"RTN","GMRCISEG",76,0)
 ;
"RTN","GMRCISEG",77,0)
 ; Output:
"RTN","GMRCISEG",78,0)
 ;  ARRAY(1)=OBX|1|TX|coding scheme|1|text||||||obs result status
"RTN","GMRCISEG",79,0)
 ;  ARRAY(2)=OBX|1|TX|coding scheme|2|text||||||obs result status
"RTN","GMRCISEG",80,0)
 ;
"RTN","GMRCISEG",81,0)
 K ^TMP("GMRCWP",$J)
"RTN","GMRCISEG",82,0)
 N GMRCPCS
"RTN","GMRCISEG",83,0)
 I GMRCOC="NW"!(GMRCOC="XO") D  Q
"RTN","GMRCISEG",84,0)
 . N SUBS S SUBS=0
"RTN","GMRCISEG",85,0)
 . F  S SUBS=$O(^GMR(123,GMRCO,20,SUBS)) Q:'SUBS  D
"RTN","GMRCISEG",86,0)
 .. S GMRCPCS(1)=1,GMRCPCS(2)="TX"
"RTN","GMRCISEG",87,0)
 .. S GMRCPCS(3)="2000.02^REASON FOR REQUEST^AS4",GMRCPCS(4)=SUBS
"RTN","GMRCISEG",88,0)
 .. S GMRCPCS(5)=$G(^GMR(123,GMRCO,20,SUBS,0)),GMRCPCS(11)="O"
"RTN","GMRCISEG",89,0)
 .. S ^TMP("GMRCWP",$J,SUBS)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISEG",90,0)
 . M @GMRCSEG=^TMP("GMRCWP",$J)
"RTN","GMRCISEG",91,0)
 . K ^TMP("GMRCWP",$J)
"RTN","GMRCISEG",92,0)
 . Q
"RTN","GMRCISEG",93,0)
 I '$D(GMRCACT)!('$D(^GMR(123,GMRCO,40,GMRCACT,1))) Q
"RTN","GMRCISEG",94,0)
 N CMT,ACTVT
"RTN","GMRCISEG",95,0)
 S CMT=0,ACTVT=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
"RTN","GMRCISEG",96,0)
 F  S CMT=$O(^GMR(123,GMRCO,40,GMRCACT,1,CMT)) Q:'CMT  D
"RTN","GMRCISEG",97,0)
 . S GMRCPCS(1)=3,GMRCPCS(2)="TX"
"RTN","GMRCISEG",98,0)
 . S GMRCPCS(3)="^COMMENTS^",GMRCPCS(4)=CMT
"RTN","GMRCISEG",99,0)
 . S GMRCPCS(5)=$G(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0))
"RTN","GMRCISEG",100,0)
 . S GMRCPCS(11)=$S(ACTVT=10:"F",1:"P") ;F if an admin comp. else "P"
"RTN","GMRCISEG",101,0)
 . S ^TMP("GMRCWP",$J,CMT)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISEG",102,0)
 M @GMRCSEG=^TMP("GMRCWP",$J)
"RTN","GMRCISEG",103,0)
 K ^TMP("GMRCWP",$J)
"RTN","GMRCISEG",104,0)
 Q
"RTN","GMRCISEG",105,0)
 ;
"RTN","GMRCISEG",106,0)
OBXRSLT(GMRCO,GMRCACT) ; build an OBX segment to send a TIU doc reference
"RTN","GMRCISEG",107,0)
 ; Input:
"RTN","GMRCISEG",108,0)
 ;  GMRCO   = ien from file 123
"RTN","GMRCISEG",109,0)
 ;  GMRCACT = activity entry in 40 multiple
"RTN","GMRCISEG",110,0)
 ;
"RTN","GMRCISEG",111,0)
 ; Output:
"RTN","GMRCISEG",112,0)
 ;  OBX segment
"RTN","GMRCISEG",113,0)
 ;    e.g. OBX|4|RP|^TIU DOC^VA8925||41320^TIU^660||||||||F
"RTN","GMRCISEG",114,0)
 ;
"RTN","GMRCISEG",115,0)
 Q:'$D(^GMR(123,GMRCO,40,GMRCACT)) ""
"RTN","GMRCISEG",116,0)
 N GMRCPCS,RSLT,GMRCACTV
"RTN","GMRCISEG",117,0)
 S GMRCPCS(1)=4,GMRCPCS(2)="RP"
"RTN","GMRCISEG",118,0)
 S GMRCPCS(4)=1
"RTN","GMRCISEG",119,0)
 S GMRCACTV=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
"RTN","GMRCISEG",120,0)
 S RSLT=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,9)
"RTN","GMRCISEG",121,0)
 I RSLT["TIU" D
"RTN","GMRCISEG",122,0)
 . S GMRCPCS(3)="^TIU DOC^VA8925"
"RTN","GMRCISEG",123,0)
 . S GMRCPCS(5)=+RSLT_"^TIU DOCUMENT^"_$$STA^XUAF4($$KSP^XUPARAM("INST"))
"RTN","GMRCISEG",124,0)
 I RSLT["MCAR" D
"RTN","GMRCISEG",125,0)
 . N MCPRNM S MCPRNM=$P($$SINGLE^MCAPI(RSLT),U)
"RTN","GMRCISEG",126,0)
 . S GMRCPCS(3)="^MED RSLT^VA"_+$P(RSLT,"MCAR(",2)
"RTN","GMRCISEG",127,0)
 . S GMRCPCS(5)=+RSLT_U_MCPRNM_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))
"RTN","GMRCISEG",128,0)
 S GMRCPCS(11)=$S(GMRCACTV=9:"S",GMRCACTV=12:"D",1:"F")
"RTN","GMRCISEG",129,0)
 Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISEG",130,0)
 ;
"RTN","GMRCISEG",131,0)
NTE(GMRCO,GMRCACT,GMRCAR) ;format an NTE seg with DC comment
"RTN","GMRCISEG",132,0)
 ; Input:
"RTN","GMRCISEG",133,0)
 ;  GMRCO   = ien from file 123
"RTN","GMRCISEG",134,0)
 ;  GMRCACT = activity entry in 40 multiple
"RTN","GMRCISEG",135,0)
 ;  GMRCAR  = array in which to pass back NTE segs
"RTN","GMRCISEG",136,0)
 ;
"RTN","GMRCISEG",137,0)
 ; Output:
"RTN","GMRCISEG",138,0)
 ;  array of NTE segments containing the comment
"RTN","GMRCISEG",139,0)
 ;   e.g. NTE|1|L|cancelled by requestor
"RTN","GMRCISEG",140,0)
 ;
"RTN","GMRCISEG",141,0)
 Q:'$D(^GMR(123,GMRCO,40,GMRCACT,1))
"RTN","GMRCISEG",142,0)
 N CMT,GMRCPCS S CMT=0
"RTN","GMRCISEG",143,0)
 F  S CMT=$O(^GMR(123,GMRCO,40,GMRCACT,1,CMT)) Q:'CMT  D
"RTN","GMRCISEG",144,0)
 . S GMRCPCS(1)=CMT,GMRCPCS(2)="L"
"RTN","GMRCISEG",145,0)
 . S GMRCPCS(3)=$G(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0))
"RTN","GMRCISEG",146,0)
 . S GMRCAR(CMT)=$$BUILD^GMRCISEG("NTE",.GMRCPCS)
"RTN","GMRCISEG",147,0)
 Q
"RTN","GMRCISEG",148,0)
 ;
"RTN","GMRCISEG",149,0)
MSA(GMRCAC,GMRCMSG,GMRCERR) ; build MSA for response to placer activity
"RTN","GMRCISEG",150,0)
 ; Input:
"RTN","GMRCISEG",151,0)
 ;  GMRCAC  = acknowledgment code  (AA or AR)
"RTN","GMRCISEG",152,0)
 ;  GMRCMSG = message number from incoming msg being responded to
"RTN","GMRCISEG",153,0)
 ;  GMRCERR = error message if can't accept the activity
"RTN","GMRCISEG",154,0)
 ;
"RTN","GMRCISEG",155,0)
 ; Output:
"RTN","GMRCISEG",156,0)
 ;  MSA segment to include with ACK or NAK
"RTN","GMRCISEG",157,0)
 ;
"RTN","GMRCISEG",158,0)
 N GMRCPCS
"RTN","GMRCISEG",159,0)
 S GMRCPCS(1)=GMRCAC
"RTN","GMRCISEG",160,0)
 S GMRCPCS(2)=GMRCMSG
"RTN","GMRCISEG",161,0)
 S GMRCPCS(3)=$G(GMRCERR)
"RTN","GMRCISEG",162,0)
 Q $$BUILD^GMRCISEG("MSA",.GMRCPCS)
"RTN","GMRCISEG",163,0)
 ;
"RTN","GMRCISEG",164,0)
OBXTZ() ;build and return an OBX with the current TIME ZONE encoded
"RTN","GMRCISEG",165,0)
 ;Input:
"RTN","GMRCISEG",166,0)
 ;  none
"RTN","GMRCISEG",167,0)
 ;
"RTN","GMRCISEG",168,0)
 ;Output:
"RTN","GMRCISEG",169,0)
 ;  OBX segment in the format:
"RTN","GMRCISEG",170,0)
 ;    OBX|5|CE|^TIME ZONE^VA4.4|1|MST||||||0
"RTN","GMRCISEG",171,0)
 N GMRCPCS
"RTN","GMRCISEG",172,0)
 S GMRCPCS(1)=5,GMRCPCS(2)="CE" ;WAT/66
"RTN","GMRCISEG",173,0)
 S GMRCPCS(3)="^TIME ZONE^VA4.4",GMRCPCS(4)=1
"RTN","GMRCISEG",174,0)
 S GMRCPCS(5)=$$GET1^DIQ(4.3,1,1)
"RTN","GMRCISEG",175,0)
 Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISEG",176,0)
 ;
"RTN","GMRCISEG",177,0)
OBXSF(GMRCO) ; build OBX seg for Sig. Find.
"RTN","GMRCISEG",178,0)
 ; Input:
"RTN","GMRCISEG",179,0)
 ;  GMRCO = ien from file 123
"RTN","GMRCISEG",180,0)
 ;
"RTN","GMRCISEG",181,0)
 ; Output:
"RTN","GMRCISEG",182,0)
 ;   OBX segment in format:
"RTN","GMRCISEG",183,0)
 ;     OBX|6|TX|^SIG FINDINGS^|1|S||||||O
"RTN","GMRCISEG",184,0)
 ;
"RTN","GMRCISEG",185,0)
 I '$L($P(^GMR(123,GMRCO,0),U,19)) Q ""
"RTN","GMRCISEG",186,0)
 N GMRCPCS
"RTN","GMRCISEG",187,0)
 S GMRCPCS(1)=6,GMRCPCS(2)="TX",GMRCPCS(3)="^SIG FINDINGS^"
"RTN","GMRCISEG",188,0)
 S GMRCPCS(4)=1,GMRCPCS(5)=$P(^GMR(123,GMRCO,0),U,19),GMRCPCS(11)="O"
"RTN","GMRCISEG",189,0)
 Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISG1")
0^11^B28005109
"RTN","GMRCISG1",1,0)
GMRCISG1 ;SLC/JFR - BUILD IFC HL7 SEGMENTS CONT'D ;08/16/10  08:59
"RTN","GMRCISG1",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**22,66**;DEC 27, 1997;Build 30
"RTN","GMRCISG1",3,0)
 ;#2171 XUAF4, #10103 XLFDT, #10106 HLFNC, #10112 VASITE, #2541 $$KSP^XUPARAM, #2056(GET1^DIQ)
"RTN","GMRCISG1",4,0)
 ;
"RTN","GMRCISG1",5,0)
 Q  ;can't start here
"RTN","GMRCISG1",6,0)
ORCRESP(GMRCO,GMRCOC,GMRCOS) ;build ORC for app ACK msgs
"RTN","GMRCISG1",7,0)
 ; Input:
"RTN","GMRCISG1",8,0)
 ;  GMRCO   = ien from file 123 of entry responding to
"RTN","GMRCISG1",9,0)
 ;  GMRCOC  = order control to put into segment
"RTN","GMRCISG1",10,0)
 ;  GMRCOS  = HL7 encoded order status to put in message
"RTN","GMRCISG1",11,0)
 ;
"RTN","GMRCISG1",12,0)
 ; Output:
"RTN","GMRCISG1",13,0)
 ;  ORC segment to use in response message
"RTN","GMRCISG1",14,0)
 ;
"RTN","GMRCISG1",15,0)
 N GMRCPCS,SITE
"RTN","GMRCISG1",16,0)
 S GMRCPCS(1)=GMRCOC
"RTN","GMRCISG1",17,0)
 S GMRCPCS(2)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))_"^GMRCIFR"
"RTN","GMRCISG1",18,0)
 S GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFC"
"RTN","GMRCISG1",19,0)
 S GMRCPCS(5)=$G(GMRCOS)
"RTN","GMRCISG1",20,0)
 S GMRCPCS(17)=$$STA^XUAF4($$KSP^XUPARAM("INST"))
"RTN","GMRCISG1",21,0)
 Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
"RTN","GMRCISG1",22,0)
 ;
"RTN","GMRCISG1",23,0)
NWORC(GMRCO) ; build ORC seg for a new order
"RTN","GMRCISG1",24,0)
 ; Input:
"RTN","GMRCISG1",25,0)
 ;  GMRCO = ien from file 123 of order to send remotely
"RTN","GMRCISG1",26,0)
 ;
"RTN","GMRCISG1",27,0)
 ; Output:
"RTN","GMRCISG1",28,0)
 ;  ORC segment to send with a new order to remote facility
"RTN","GMRCISG1",29,0)
 ;
"RTN","GMRCISG1",30,0)
 N GMRCPCS,SITE,GMRCPHN,GMRCPAG
"RTN","GMRCISG1",31,0)
 S GMRCPCS(1)="NW"
"RTN","GMRCISG1",32,0)
 S GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFR"
"RTN","GMRCISG1",33,0)
 S $P(GMRCPCS(7),U,4)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,24)) ;wat/66
"RTN","GMRCISG1",34,0)
 S $P(GMRCPCS(7),U,6)=$$URG^GMRCIUTL(GMRCO)
"RTN","GMRCISG1",35,0)
 S GMRCPCS(9)=$$FMTHL7^XLFDT(+^GMR(123,GMRCO,0))
"RTN","GMRCISG1",36,0)
 S GMRCPCS(10)=$$HLNAME^GMRCIUTL($P($G(^GMR(123,GMRCO,40,1,0)),U,5))
"RTN","GMRCISG1",37,0)
 S GMRCPCS(12)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,0),U,14))
"RTN","GMRCISG1",38,0)
 S GMRCPHN=$$GET1^DIQ(200,$P(^GMR(123,GMRCO,0),U,14),.132)
"RTN","GMRCISG1",39,0)
 S GMRCPAG=$$GET1^DIQ(200,$P(^GMR(123,GMRCO,0),U,14),.138)
"RTN","GMRCISG1",40,0)
 S GMRCPCS(14)=$$HLPHONE^HLFNC(GMRCPHN,GMRCPAG)
"RTN","GMRCISG1",41,0)
 S GMRCPCS(15)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,7))
"RTN","GMRCISG1",42,0)
 I $O(^GMR(123,GMRCO,40,1)) D
"RTN","GMRCISG1",43,0)
 . N I,ACTV S I=1
"RTN","GMRCISG1",44,0)
 . F  S I=$O(^GMR(123,GMRCO,40,I)) Q:'I  S ACTV=$P(^(I,0),U,2) D
"RTN","GMRCISG1",45,0)
 .. I ACTV'=25 Q
"RTN","GMRCISG1",46,0)
 .. S GMRCPCS(16)="FI^FORWARD TO IFC^99GMRC"
"RTN","GMRCISG1",47,0)
 S SITE=$$SITE^VASITE
"RTN","GMRCISG1",48,0)
 I +SITE S GMRCPCS(17)=$P(SITE,U,3)_U_$P(SITE,U,2) ;use loc instead? ;-(
"RTN","GMRCISG1",49,0)
 Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
"RTN","GMRCISG1",50,0)
OBXPD(GMRCO) ; create OBX segment for the prov. dx
"RTN","GMRCISG1",51,0)
 ; Input:
"RTN","GMRCISG1",52,0)
 ;  GMRCO  = ien from file 123 of order to send remotely
"RTN","GMRCISG1",53,0)
 ;
"RTN","GMRCISG1",54,0)
 ; Output:
"RTN","GMRCISG1",55,0)
 ;  OBX segment containing the Provisional Diagnosis
"RTN","GMRCISG1",56,0)
 ;
"RTN","GMRCISG1",57,0)
 Q:'$L($G(^GMR(123,GMRCO,30))) ""
"RTN","GMRCISG1",58,0)
 N GMRCPCS
"RTN","GMRCISG1",59,0)
 S GMRCPCS(1)=2,GMRCPCS(2)=$S($L($G(^GMR(123,GMRCO,30.1))):"CE",1:"TX")
"RTN","GMRCISG1",60,0)
 S GMRCPCS(3)="^PROVISIONAL DIAGNOSIS^",GMRCPCS(4)=1
"RTN","GMRCISG1",61,0)
 S GMRCPCS(11)="O"
"RTN","GMRCISG1",62,0)
 I $L($G(^GMR(123,GMRCO,30.1))) D  Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISG1",63,0)
 . ;coded diagnosis
"RTN","GMRCISG1",64,0)
 . S GMRCPCS(5)=$G(^GMR(123,GMRCO,30.1))_U_$G(^(30))_U_"I9C"
"RTN","GMRCISG1",65,0)
 S GMRCPCS(5)=U_$G(^GMR(123,GMRCO,30))_U ;free text dx
"RTN","GMRCISG1",66,0)
 Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
"RTN","GMRCISG1",67,0)
 ;
"RTN","GMRCISG1",68,0)
OBR(GMRCO,GMRCACT) ; build an OBR seg for new order or resubmit
"RTN","GMRCISG1",69,0)
 ; Input:
"RTN","GMRCISG1",70,0)
 ;  GMRCO   = ien from file 123
"RTN","GMRCISG1",71,0)
 ;  GMRCACT = ien from 40 multiple of action (only on resubmit or fwd)
"RTN","GMRCISG1",72,0)
 ;
"RTN","GMRCISG1",73,0)
 ; Output:
"RTN","GMRCISG1",74,0)
 ;  OBR segment
"RTN","GMRCISG1",75,0)
 ;
"RTN","GMRCISG1",76,0)
 N GMRCPCS,GMRCROL
"RTN","GMRCISG1",77,0)
 S GMRCPCS(1)=1
"RTN","GMRCISG1",78,0)
 S GMRCROL=$P(^GMR(123,GMRCO,12),U,5)
"RTN","GMRCISG1",79,0)
 I GMRCROL="P" D
"RTN","GMRCISG1",80,0)
 . S GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFR"
"RTN","GMRCISG1",81,0)
 I $D(GMRCACT) D  ;  resubmit sends filler # too
"RTN","GMRCISG1",82,0)
 . I GMRCROL="P" D
"RTN","GMRCISG1",83,0)
 .. S GMRCPCS(3)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
"RTN","GMRCISG1",84,0)
 .. S GMRCPCS(3)=GMRCPCS(3)_U_"GMRCIFC"
"RTN","GMRCISG1",85,0)
 . I GMRCROL="F" D
"RTN","GMRCISG1",86,0)
 .. S GMRCPCS(2)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
"RTN","GMRCISG1",87,0)
 .. S GMRCPCS(2)=GMRCPCS(2)_U_"GMRCIFR"
"RTN","GMRCISG1",88,0)
 .. S GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFC"
"RTN","GMRCISG1",89,0)
 I $D(GMRCACT),$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=17 D
"RTN","GMRCISG1",90,0)
 . ;FWD uses txt of current svc
"RTN","GMRCISG1",91,0)
 . N SITE,SERVNM,SERV
"RTN","GMRCISG1",92,0)
 . S SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))_"VA1235"
"RTN","GMRCISG1",93,0)
 . I GMRCROL="F" S SERV=$P(^GMR(123,GMRCO,0),U,5)
"RTN","GMRCISG1",94,0)
 . I GMRCROL="P" S SERV=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,6)
"RTN","GMRCISG1",95,0)
 . S SERVNM=$S(+SERV:$P(^GMR(123.5,SERV,0),U),1:"")
"RTN","GMRCISG1",96,0)
 . S GMRCPCS(4)=SERV_U_SERVNM_U_SITE
"RTN","GMRCISG1",97,0)
 I $D(GMRCACT),$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=25 D
"RTN","GMRCISG1",98,0)
 . ;FWD to IFC uses the FORWARDED FROM service name
"RTN","GMRCISG1",99,0)
 . N SITE,SERVNM,SERV
"RTN","GMRCISG1",100,0)
 . S SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))_"VA1235"
"RTN","GMRCISG1",101,0)
 . S SERV=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,6)
"RTN","GMRCISG1",102,0)
 . I '+SERV Q
"RTN","GMRCISG1",103,0)
 . S SERVNM=$P(^GMR(123.5,SERV,0),U)
"RTN","GMRCISG1",104,0)
 . S GMRCPCS(4)=SERV_U_SERVNM_U_SITE
"RTN","GMRCISG1",105,0)
 I '$D(GMRCPCS(4)) D
"RTN","GMRCISG1",106,0)
 . S GMRCPCS(4)=$$CODEOI^GMRCIUTL(GMRCO) ;get remote service or proc
"RTN","GMRCISG1",107,0)
 I $D(GMRCACT) D  ;resubmit or fwd so use activity fields for msg
"RTN","GMRCISG1",108,0)
 . S GMRCPCS(6)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,40,GMRCACT,0),U,3))
"RTN","GMRCISG1",109,0)
 . S GMRCPCS(16)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,40,GMRCACT,0),U,4))
"RTN","GMRCISG1",110,0)
 I '$D(GMRCACT) D  ; new order being sent
"RTN","GMRCISG1",111,0)
 . S GMRCPCS(6)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,7))
"RTN","GMRCISG1",112,0)
 . S GMRCPCS(16)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,0),U,14))
"RTN","GMRCISG1",113,0)
 S GMRCPCS(18)=$P(^GMR(123,GMRCO,0),U,18)
"RTN","GMRCISG1",114,0)
 Q $$BUILD^GMRCISEG("OBR",.GMRCPCS)
"RTN","GMRCISG1",115,0)
 ;
"RTN","GMRCISG1",116,0)
ORCTST() ;build ORC for testing imp.
"RTN","GMRCISG1",117,0)
 ;Input:
"RTN","GMRCISG1",118,0)
 ;
"RTN","GMRCISG1",119,0)
 ;Output:
"RTN","GMRCISG1",120,0)
 ; ORC segment used to test IFC implementation
"RTN","GMRCISG1",121,0)
 ;
"RTN","GMRCISG1",122,0)
 N GMRCPCS,SITE,GMRCRP
"RTN","GMRCISG1",123,0)
 S GMRCPCS(1)="NW"
"RTN","GMRCISG1",124,0)
 S GMRCPCS(2)="TST1234"_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFR"
"RTN","GMRCISG1",125,0)
 S GMRCPCS(9)=$$FMTHL7^XLFDT($$NOW^XLFDT)
"RTN","GMRCISG1",126,0)
 S GMRCPCS(10)="PUBLIC^JOHN^Q"
"RTN","GMRCISG1",127,0)
 S GMRCPCS(16)="T^TESTING^99GMRC"
"RTN","GMRCISG1",128,0)
 Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
"RTN","GMRCISG1",129,0)
 ;
"RTN","GMRCISG1",130,0)
 ;
"RTN","GMRCISG1",131,0)
OBRTST(GMRCOI,GMRCTYP) ; build OBR seg for testing imp.
"RTN","GMRCISG1",132,0)
 ; Input:
"RTN","GMRCISG1",133,0)
 ;  GMRCOI   = ien from file 123.5 or 123.3
"RTN","GMRCISG1",134,0)
 ;  GMRCTYP = "P" or "C"   (procedure or consult service)
"RTN","GMRCISG1",135,0)
 ;
"RTN","GMRCISG1",136,0)
 ; Output:
"RTN","GMRCISG1",137,0)
 ;  OBR segment used to test implementation
"RTN","GMRCISG1",138,0)
 ;
"RTN","GMRCISG1",139,0)
 N GMRCPCS,SITE
"RTN","GMRCISG1",140,0)
 S SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
"RTN","GMRCISG1",141,0)
 S GMRCPCS(1)=1
"RTN","GMRCISG1",142,0)
 S GMRCPCS(2)="TST1234"_U_SITE_"^GMRCIFR"
"RTN","GMRCISG1",143,0)
 I GMRCTYP="C" D
"RTN","GMRCISG1",144,0)
 . N SERV
"RTN","GMRCISG1",145,0)
 . S SERV=$P(^GMR(123.5,GMRCOI,"IFC"),U,2)
"RTN","GMRCISG1",146,0)
 . S GMRCPCS(4)=GMRCOI_U_SERV_U_SITE_"VA1235"
"RTN","GMRCISG1",147,0)
 I GMRCTYP="P" D
"RTN","GMRCISG1",148,0)
 . N PROC
"RTN","GMRCISG1",149,0)
 . S PROC=$P(^GMR(123.3,GMRCOI,"IFC"),U,2)
"RTN","GMRCISG1",150,0)
 . S GMRCPCS(4)=GMRCOI_U_PROC_U_SITE_"VA1233"
"RTN","GMRCISG1",151,0)
 Q $$BUILD^GMRCISEG("OBR",.GMRCPCS)
"RTN","GMRCISG1",152,0)
 ;
"RTN","GMRCP5B")
0^8^B37235428
"RTN","GMRCP5B",1,0)
GMRCP5B ;SLC/DCM,RJS,WAT - Print Consult form 513 (Gather Data - Footers, Provisional Diagnosis and Reason For Request) ;03/04/09  11:42
"RTN","GMRCP5B",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**4,13,12,15,24,23,22,29,65,66**;Dec 27, 1997;Build 30
"RTN","GMRCP5B",3,0)
 ;
"RTN","GMRCP5B",4,0)
 ; Patch #23 add "SERVICE RENDERED AS:" to SF513
"RTN","GMRCP5B",5,0)
 ; This routine invokes IA #1252 (SDUTL3),#10112 (VASITE)
"RTN","GMRCP5B",6,0)
 ; DBIA 10035      ;PATIENT FILE
"RTN","GMRCP5B",7,0)
 ; DBIA 2849       ;PROTOCOL
"RTN","GMRCP5B",8,0)
 ; DBIA 10060      ;NEW PERSON
"RTN","GMRCP5B",9,0)
 ; DBIA 10061      ;VADPT
"RTN","GMRCP5B",10,0)
 ; 10103           ;FMTE^XLFDT
"RTN","GMRCP5B",11,0)
 ; 10003           ;%DT
"RTN","GMRCP5B",12,0)
 ; 2056            ;$$GET1^DIQ
"RTN","GMRCP5B",13,0)
 ; ICR 4156        ;REGISTRATION, COMBAT VETERAN STATUS
"RTN","GMRCP5B",14,0)
 Q
"RTN","GMRCP5B",15,0)
 ;
"RTN","GMRCP5B",16,0)
INIT(GMRCSG) ; Initialize the form
"RTN","GMRCP5B",17,0)
 ;
"RTN","GMRCP5B",18,0)
 D HDR^GMRCP5D,FTR(.GMRCSG),REQUEST,PDIAG Q
"RTN","GMRCP5B",19,0)
 ;
"RTN","GMRCP5B",20,0)
REQUEST ;
"RTN","GMRCP5B",21,0)
 N GMRCX
"RTN","GMRCP5B",22,0)
 ;
"RTN","GMRCP5B",23,0)
 I $L($T(OUTPTPR^SDUTL3)) D
"RTN","GMRCP5B",24,0)
 .S GMRCX=$P($$OUTPTPR^SDUTL3(DFN),U,2)
"RTN","GMRCP5B",25,0)
 .D:$L(GMRCX) BLD("REQ",1,1,0,"Current Primary Care Provider: "_GMRCX)
"RTN","GMRCP5B",26,0)
 I $L($T(OUTPTTM^SDUTL3)) D
"RTN","GMRCP5B",27,0)
 .S GMRCX=$P($$OUTPTTM^SDUTL3(DFN),U,2)
"RTN","GMRCP5B",28,0)
 .D:$L(GMRCX) BLD("REQ",1,1,0,"    Current Primary Care Team: "_GMRCX)
"RTN","GMRCP5B",29,0)
 ;
"RTN","GMRCP5B",30,0)
 I $O(^TMP("GMRC",$J,"OUTPUT","REQ",0)) D BLD("REQ",1,1,0,"")
"RTN","GMRCP5B",31,0)
 ;
"RTN","GMRCP5B",32,0)
 D SUB("H","REQ",1,"Reason For Request continued.")
"RTN","GMRCP5B",33,0)
 D SUB("H","REQ",1," ")
"RTN","GMRCP5B",34,0)
 ;
"RTN","GMRCP5B",35,0)
 D BLD("REQ",1,1,0,"REASON FOR REQUEST: (Complaints and findings)")
"RTN","GMRCP5B",36,0)
 I '$O(^GMR(123,GMRCIFN,20,0)) D BLD("REQ",1,1,0,"") I 1
"RTN","GMRCP5B",37,0)
 E  D
"RTN","GMRCP5B",38,0)
 .N LN S LN=0 F  S LN=$O(^GMR(123,GMRCIFN,20,LN)) Q:LN=""  D
"RTN","GMRCP5B",39,0)
 ..D BLD("REQ",1,1,0,^GMR(123,GMRCIFN,20,LN,0))
"RTN","GMRCP5B",40,0)
 ;
"RTN","GMRCP5B",41,0)
 Q
"RTN","GMRCP5B",42,0)
PDIAG ;
"RTN","GMRCP5B",43,0)
 ;
"RTN","GMRCP5B",44,0)
 D BLD("PDIAG",1,1,0,"PROVISIONAL DIAG: "_$G(^GMR(123,GMRCIFN,30)))
"RTN","GMRCP5B",45,0)
 D BLD("PDIAG",1,1,0,GMRCDVL)
"RTN","GMRCP5B",46,0)
 ;
"RTN","GMRCP5B",47,0)
 S (GMRCQSTR,GMRCPGR,GMRCIPH,GMRCQSTT)=""
"RTN","GMRCP5B",48,0)
 ;
"RTN","GMRCP5B",49,0)
 I $S('$P(GMRCRD,U,23):1,$P(GMRCRD(12),U,5)="P":1,1:0) D
"RTN","GMRCP5B",50,0)
 .S GMRCQSTR=$P(GMRCRD,U,14)
"RTN","GMRCP5B",51,0)
 .S:'GMRCQSTR GMRCQSTR=$$GET1^DIQ(100,+$P(GMRCRD,U,3),1)
"RTN","GMRCP5B",52,0)
 .S GMRCPGR=$$GET1^DIQ(200,+$G(GMRCQSTR),.137) S:'$L(GMRCPGR) GMRCPGR=$$GET1^DIQ(200,+$G(GMRCQSTR),.138)
"RTN","GMRCP5B",53,0)
 .S GMRCIPH=$$GET1^DIQ(200,$G(GMRCQSTR),.132)
"RTN","GMRCP5B",54,0)
 .;
"RTN","GMRCP5B",55,0)
 .S GMRCQSTT=$$GET1^DIQ(200,+$G(GMRCQSTR),20.3)
"RTN","GMRCP5B",56,0)
 .S:'$L(GMRCQSTT) GMRCQSTT=$$GET1^DIQ(200,+$G(GMRCQSTR),8)
"RTN","GMRCP5B",57,0)
 .S GMRCQSTR=$$GET1^DIQ(200,+$G(GMRCQSTR),.01)
"RTN","GMRCP5B",58,0)
 ;
"RTN","GMRCP5B",59,0)
 I $P(GMRCRD,U,23),$P(GMRCRD(12),U,5)="F" D
"RTN","GMRCP5B",60,0)
 .S GMRCQSTR=$P(GMRCRD(12),U,6)
"RTN","GMRCP5B",61,0)
 .S GMRCIPH=$P(GMRCRD(13),U,2)
"RTN","GMRCP5B",62,0)
 .S GMRCPGR=$P(GMRCRD(13),U,3)
"RTN","GMRCP5B",63,0)
 ;
"RTN","GMRCP5B",64,0)
 S GMRCIPH="(Phone: "_GMRCIPH_")"
"RTN","GMRCP5B",65,0)
 S GMRCPGR="(Pager: "_GMRCPGR_")"
"RTN","GMRCP5B",66,0)
 ;
"RTN","GMRCP5B",67,0)
 D BLD("PDIAG",1,1,0,"REQUESTED BY: ")
"RTN","GMRCP5B",68,0)
 D BLD("PDIAG",1,0,35,"|PLACE:")
"RTN","GMRCP5B",69,0)
 D BLD("PDIAG",1,0,59,"|URGENCY:")
"RTN","GMRCP5B",70,0)
 ;
"RTN","GMRCP5B",71,0)
 D BLD("PDIAG",1,1,0,$E(GMRCQSTR,1,37))
"RTN","GMRCP5B",72,0)
 D BLD("PDIAG",1,0,35,"|"_$E($P($G(^ORD(101,+$P(GMRCRD,U,10),0)),U,2),1,20))
"RTN","GMRCP5B",73,0)
 D BLD("PDIAG",1,0,59,"|"_$E($P($G(^ORD(101,+$P(GMRCRD,U,9),0)),U,2),1,18))
"RTN","GMRCP5B",74,0)
 ;
"RTN","GMRCP5B",75,0)
 I $L(GMRCQSTT) D
"RTN","GMRCP5B",76,0)
 .D BLD("PDIAG",1,1,0,GMRCQSTT)
"RTN","GMRCP5B",77,0)
 .D BLD("PDIAG",1,0,35,"|")
"RTN","GMRCP5B",78,0)
 .D BLD("PDIAG",1,0,59,"|")
"RTN","GMRCP5B",79,0)
 D BLD("PDIAG",1,1,0,GMRCPGR)
"RTN","GMRCP5B",80,0)
 D BLD("PDIAG",1,0,35,"|SERVICE RENDERED AS:")
"RTN","GMRCP5B",81,0)
 D BLD("PDIAG",1,0,59,"|EARLIEST DATE:") ;WAT/66
"RTN","GMRCP5B",82,0)
 D BLD("PDIAG",1,0,59,"|")
"RTN","GMRCP5B",83,0)
 S GMRCINOU=$S($P(GMRCRD,U,18)="O":"Outpatient",1:"Inpatient")
"RTN","GMRCP5B",84,0)
 I $D(GMRCIPH)>0 D
"RTN","GMRCP5B",85,0)
 .D BLD("PDIAG",1,1,0,GMRCIPH)
"RTN","GMRCP5B",86,0)
 .D BLD("PDIAG",1,0,35,"|"_GMRCINOU)
"RTN","GMRCP5B",87,0)
 E  D
"RTN","GMRCP5B",88,0)
 .D BLD("PDIAG",1,1,35,"|"_GMRCINOU)
"RTN","GMRCP5B",89,0)
 D BLD("PDIAG",1,0,59,"|")
"RTN","GMRCP5B",90,0)
 D BLD("PDIAG",1,0,59,"|"_$$FMTE^XLFDT($P(GMRCRD,U,24),1)) ;WAT/66
"RTN","GMRCP5B",91,0)
 K GMRCINOU
"RTN","GMRCP5B",92,0)
 ;***************************************************************
"RTN","GMRCP5B",93,0)
 D BLD("PDIAG",1,1,0,GMRCDVL)
"RTN","GMRCP5B",94,0)
 ;
"RTN","GMRCP5B",95,0)
 Q
"RTN","GMRCP5B",96,0)
 ;
"RTN","GMRCP5B",97,0)
FTR(GMRCSG) ;Footer of form 513
"RTN","GMRCP5B",98,0)
 ;
"RTN","GMRCP5B",99,0)
 N GMRCRMBD,GMRCFAC1,GMRCLOC,GMRCX,SUB,VAIN,VAPA,VAERR
"RTN","GMRCP5B",100,0)
 ;
"RTN","GMRCP5B",101,0)
 D ADD^VADPT,INP^VADPT
"RTN","GMRCP5B",102,0)
 ;
"RTN","GMRCP5B",103,0)
 S (GMRCLOC,GMRCRMBD)=""
"RTN","GMRCP5B",104,0)
 S GMRCLOC=$P($G(VAIN(4)),U,2)
"RTN","GMRCP5B",105,0)
 S GMRCRMBD=$G(VAIN(5))
"RTN","GMRCP5B",106,0)
 S:'$L(GMRCLOC) GMRCLOC=$P($G(^SC(+$P($G(^GMR(123,+GMRCIFN,0)),U,4),0)),U,1)
"RTN","GMRCP5B",107,0)
 ;No location, IFC - consulting site
"RTN","GMRCP5B",108,0)
 I '$L(GMRCLOC),$P(GMRCRD,U,23),$P($G(GMRCRD(12)),U,5)="F" D
"RTN","GMRCP5B",109,0)
 .I $P(GMRCRD,U,21) S GMRCLOC=$$GET1^DIQ(4,$P(GMRCRD,U,21),.01)
"RTN","GMRCP5B",110,0)
 .E  S GMRCLOC=$$GET1^DIQ(4,$P(GMRCRD,U,23),.01)
"RTN","GMRCP5B",111,0)
 S:'$L(GMRCLOC) GMRCLOC=GMRCUL
"RTN","GMRCP5B",112,0)
 ;
"RTN","GMRCP5B",113,0)
 D BLD("FTR",0,1,0,GMRCEQL)
"RTN","GMRCP5B",114,0)
 D BLD("FTR",1,1,0,GMRCEQL)
"RTN","GMRCP5B",115,0)
 ;
"RTN","GMRCP5B",116,0)
 I ($G(GMRCSG("GMRCSIGM"))="electronic") D  I 1
"RTN","GMRCP5B",117,0)
 .D BLD("FTR",0,1,0,"SIGNATURE & TITLE: ")
"RTN","GMRCP5B",118,0)
 .D BLD("FTR",0,0,20,$G(GMRCSG("GMRCSIG"))_" /es/")
"RTN","GMRCP5B",119,0)
 .D BLD("FTR",0,0,54,"|")
"RTN","GMRCP5B",120,0)
 .D BLD("FTR",0,1,20,$G(GMRCSG("GMRCSIGT")))
"RTN","GMRCP5B",121,0)
 .D BLD("FTR",0,0,54,"|DATE: "_$$EXDT($G(GMRCSG("GMRCSDT"))))
"RTN","GMRCP5B",122,0)
 E  D
"RTN","GMRCP5B",123,0)
 .D BLD("FTR",0,1,0,"AUTHOR & TITLE: ")
"RTN","GMRCP5B",124,0)
 .D BLD("FTR",0,0,20,$G(GMRCSG("GMRCSIG")))
"RTN","GMRCP5B",125,0)
 .D BLD("FTR",0,0,54,"|")
"RTN","GMRCP5B",126,0)
 .D BLD("FTR",0,1,20,$G(GMRCSG("GMRCSIGT")))
"RTN","GMRCP5B",127,0)
 .D BLD("FTR",0,0,54,"|DATE: "_$$EXDT($G(GMRCSG("GMRCSDT"))))
"RTN","GMRCP5B",128,0)
 ;
"RTN","GMRCP5B",129,0)
 S GMRCFAC1=+$G(DUZ(2))
"RTN","GMRCP5B",130,0)
 S:'GMRCFAC1 GMRCFAC1=+$$SITE^VASITE()
"RTN","GMRCP5B",131,0)
 S GMRCFAC1=$$GET1^DIQ(4,+GMRCFAC1,.01)
"RTN","GMRCP5B",132,0)
 ;
"RTN","GMRCP5B",133,0)
 D BLD("FTR",0,1,0,GMRCDVL)
"RTN","GMRCP5B",134,0)
 D BLD("FTR",0,1,0,"ID #:"_$E(GMRCUL,1,8))
"RTN","GMRCP5B",135,0)
 D BLD("FTR",0,0,12,"|ORGANIZATION:"_$J($E(GMRCFAC1,1,17),17))
"RTN","GMRCP5B",136,0)
 D BLD("FTR",0,0,45,"|REG #:"_$E(GMRCUL,1,4))
"RTN","GMRCP5B",137,0)
 D BLD("FTR",0,0,58,"|LOC: "_$E($G(GMRCLOC),1,11))
"RTN","GMRCP5B",138,0)
 ;
"RTN","GMRCP5B",139,0)
 I $L(GMRCRMBD) D  I 1
"RTN","GMRCP5B",140,0)
 .D BLD("FTR",0,1,12,"|")
"RTN","GMRCP5B",141,0)
 .D BLD("FTR",0,0,45,"|")
"RTN","GMRCP5B",142,0)
 .D BLD("FTR",0,0,58,"|RM/BD: "_GMRCRMBD)
"RTN","GMRCP5B",143,0)
 ;
"RTN","GMRCP5B",144,0)
 D BLD("FTR",0,1,0,GMRCDVL)
"RTN","GMRCP5B",145,0)
 ;
"RTN","GMRCP5B",146,0)
 F SUB=0,1 D
"RTN","GMRCP5B",147,0)
 .I SUB D BLD("FTR",SUB,1,33,"Page ","GMRCPG,38"_" FIRST ONE") I 1
"RTN","GMRCP5B",148,0)
 .E  I '$G(GMRCGUI) D BLD("FTR",SUB,1,33,"Page ","GMRCPG,38"_" SECOND ONE")
"RTN","GMRCP5B",149,0)
 I $G(GMRCPG)=0 D BLD("FTR",0,1,51,"Standard Form 513 (Rev 9-77)")
"RTN","GMRCP5B",150,0)
 Q
"RTN","GMRCP5B",151,0)
 ;
"RTN","GMRCP5B",152,0)
CONSRQ(GMRCRQ) ;
"RTN","GMRCP5B",153,0)
 ;
"RTN","GMRCP5B",154,0)
 N ORND,ORFL,REF
"RTN","GMRCP5B",155,0)
 I '$L(GMRCRQ) Q "Consult"
"RTN","GMRCP5B",156,0)
 S ORND=$P(GMRCRQ,";",1),ORFL=$P(GMRCRQ,";",2),REF=U_ORFL_ORND_",0)"
"RTN","GMRCP5B",157,0)
 S GMRCRQ=$P($G(@(REF)),U,2)
"RTN","GMRCP5B",158,0)
 Q:$L(GMRCRQ) GMRCRQ Q "Consult"
"RTN","GMRCP5B",159,0)
 ;
"RTN","GMRCP5B",160,0)
EXDT(X) ;EXTERNAL DATE FORMAT
"RTN","GMRCP5B",161,0)
 ;
"RTN","GMRCP5B",162,0)
 N DATE,TIME,HR,MN,PD,Y,%DT
"RTN","GMRCP5B",163,0)
 Q:'$L(X) ""
"RTN","GMRCP5B",164,0)
 I '(X?7N.1".".6N) S %DT="PTS" D ^%DT S X=Y
"RTN","GMRCP5B",165,0)
 Q $$FMTE^XLFDT(X,"5PMZ")
"RTN","GMRCP5B",166,0)
 ;
"RTN","GMRCP5B",167,0)
PRCMT(CMT) ;
"RTN","GMRCP5B",168,0)
 ;
"RTN","GMRCP5B",169,0)
 Q $P($G(^GMR(123.1,+CMT,0)),U,8)
"RTN","GMRCP5B",170,0)
 ;
"RTN","GMRCP5B",171,0)
 ;
"RTN","GMRCP5B",172,0)
BLD(SUB,NDX,LINE,TAB,TEXT,RUNTIME) ;
"RTN","GMRCP5B",173,0)
 ;
"RTN","GMRCP5B",174,0)
 Q:'$L($G(SUB))
"RTN","GMRCP5B",175,0)
 N LINECNT
"RTN","GMRCP5B",176,0)
 ;
"RTN","GMRCP5B",177,0)
 F LINECNT=1:1:+LINE S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX)+1,0)=""
"RTN","GMRCP5B",178,0)
 ;
"RTN","GMRCP5B",179,0)
 S $E(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),0),TAB+1)=TEXT
"RTN","GMRCP5B",180,0)
 I $L($G(RUNTIME)) S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),1)=RUNTIME
"RTN","GMRCP5B",181,0)
 ;
"RTN","GMRCP5B",182,0)
 S GMRCLAST=SUB
"RTN","GMRCP5B",183,0)
 Q
"RTN","GMRCP5B",184,0)
 ;
"RTN","GMRCP5B",185,0)
SUB(ZONE,SUB,NDX,TEXT) ;
"RTN","GMRCP5B",186,0)
 ;
"RTN","GMRCP5B",187,0)
 N NEXT
"RTN","GMRCP5B",188,0)
 S NEXT=$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE," "),-1)+1
"RTN","GMRCP5B",189,0)
 S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE,NEXT,0)=TEXT
"RTN","GMRCP5B",190,0)
 Q
"RTN","GMRCP5B",191,0)
 ;
"RTN","GMRCP5B",192,0)
LASTLN(SUB,NDX) ;
"RTN","GMRCP5B",193,0)
 Q +$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX," "),-1)
"RTN","GMRCP5B",194,0)
 ;
"RTN","GMRCP5D")
0^10^B71660490
"RTN","GMRCP5D",1,0)
GMRCP5D ;SLC/DCM,RJS,JFR,WAT - Print Consult form 513 (Gather Data - Addendums, Headers, Service reports and Comments) ;03/18/09  15:00
"RTN","GMRCP5D",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29,35,38,61,65,66**;Dec 27, 1997;Build 30
"RTN","GMRCP5D",3,0)
 ;
"RTN","GMRCP5D",4,0)
 ;This routine invokes the following ICR(s):
"RTN","GMRCP5D",5,0)
 ;2056 $$GET1^DIQ, 2541 $$KSP^XUPARAM, 10103 $$FMTE^XLFDT, 10104 $$UP^XLFSTR, 10061 VADPT API
"RTN","GMRCP5D",6,0)
 ;10040 ^SC(, 4156 $$CVEDT^DGCV, 10060 ^VA(200
"RTN","GMRCP5D",7,0)
 ;
"RTN","GMRCP5D",8,0)
FORMAT(GMRCIFN,GMRCRD,PAGEWID) ;
"RTN","GMRCP5D",9,0)
 ;
"RTN","GMRCP5D",10,0)
 I $L($P(GMRCRD,U,15)) D
"RTN","GMRCP5D",11,0)
 .I $O(^TMP("GMRCR",$J,"MCAR",0)) D
"RTN","GMRCP5D",12,0)
 ..N GMRCSVC
"RTN","GMRCP5D",13,0)
 ..S GMRCSVC=$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1)
"RTN","GMRCP5D",14,0)
 ..S:$L(GMRCSVC) GMRCSVC=GMRCSVC_" "
"RTN","GMRCP5D",15,0)
 ..;
"RTN","GMRCP5D",16,0)
 ..; Medicine Results?
"RTN","GMRCP5D",17,0)
 ..S GMRCR0=0 F  S GMRCR0=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0)) Q:'GMRCR0  D
"RTN","GMRCP5D",18,0)
 ...D SUB("H","SREP",GMRCR0,$$CENTER(GMRCSVC_"Service Report #"_GMRCR0_" continued."))
"RTN","GMRCP5D",19,0)
 ...D SUB("H","SREP",GMRCR0," ")
"RTN","GMRCP5D",20,0)
 ...D BLD("SREP",GMRCR0,1,0,$$CENTER("Medicine Package Report"))
"RTN","GMRCP5D",21,0)
 ...D BLD("SREP",GMRCR0,1,0,"")
"RTN","GMRCP5D",22,0)
 ...N LN
"RTN","GMRCP5D",23,0)
 ...S LN=0 F  S LN=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN)) Q:'LN  D
"RTN","GMRCP5D",24,0)
 ....D BLD("SREP",GMRCR0,1,0,$G(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN,0)))
"RTN","GMRCP5D",25,0)
 ;
"RTN","GMRCP5D",26,0)
 ; Build Processing Activities
"RTN","GMRCP5D",27,0)
 S GMRCR0=0 F  S GMRCR0=$O(^GMR(123,GMRCIFN,40,GMRCR0)) Q:'GMRCR0  D
"RTN","GMRCP5D",28,0)
 .N GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402,GMRCISIT
"RTN","GMRCP5D",29,0)
 .S GMRCR1=+$O(^GMR(123,GMRCIFN,40,GMRCR0,0)) Q:GMRCR1'=1
"RTN","GMRCP5D",30,0)
 .S GMRC400=$G(^GMR(123,GMRCIFN,40,GMRCR0,0))
"RTN","GMRCP5D",31,0)
 .S GMRC402=$G(^GMR(123,GMRCIFN,40,GMRCR0,2))
"RTN","GMRCP5D",32,0)
 .S CMT=$$PRCMT^GMRCP5B(+$P(GMRC400,U,2)) Q:'$L(CMT)
"RTN","GMRCP5D",33,0)
 .S GMRCDT=$P(GMRC400,U,3) S:'GMRCDT GMRCDT=$P(GMRC400,U,1)
"RTN","GMRCP5D",34,0)
 .S GMRCDT=$$EXDT(GMRCDT)_" "_$P(GMRC402,U,3)
"RTN","GMRCP5D",35,0)
 .;Following lines modified in patch *38
"RTN","GMRCP5D",36,0)
 .;I $P(^GMR(123,GMRCIFN,0),U,23) D  ;commented out
"RTN","GMRCP5D",37,0)
 .;.S GMRCISIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCIFN,0),U,23),.01)  ;commented out
"RTN","GMRCP5D",38,0)
 .;.S GMRCISIT="Entered at: "_GMRCISIT  ;commented out
"RTN","GMRCP5D",39,0)
 .I $L(GMRC402) D  ;ADDED
"RTN","GMRCP5D",40,0)
 ..S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.07)  ;ADDED
"RTN","GMRCP5D",41,0)
 .I '$D(GMRCISIT) D  ;ADDED
"RTN","GMRCP5D",42,0)
 ..S GMRCISIT=$$KSP^XUPARAM("INST")  ;ADDED
"RTN","GMRCP5D",43,0)
 ..I GMRCISIT'="" S GMRCISIT=$$GET1^DIQ(4,GMRCISIT,.01)  ;ADDED
"RTN","GMRCP5D",44,0)
 ..I GMRCISIT="" S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.05)  ;ADDED
"RTN","GMRCP5D",45,0)
 .S GMRCISIT="Entered at: "_GMRCISIT  ;ADDED
"RTN","GMRCP5D",46,0)
 .;End of modifications for patch *38
"RTN","GMRCP5D",47,0)
 .S RPRV=$$GET1^DIQ(200,+$P(GMRC400,U,4),.01)
"RTN","GMRCP5D",48,0)
 .I '$L(RPRV) S RPRV=$P(GMRC402,U,2)
"RTN","GMRCP5D",49,0)
 .S:($L(RPRV)) RPRV="Responsible Person: "_RPRV
"RTN","GMRCP5D",50,0)
 .S USER=$$GET1^DIQ(200,+$P(GMRC400,U,5),.01)
"RTN","GMRCP5D",51,0)
 .I '$L(USER) S USER=$P(GMRC402,U)
"RTN","GMRCP5D",52,0)
 .S USER="Entered by: "_USER_" - "_GMRCDT
"RTN","GMRCP5D",53,0)
 .D SUB("H","COM",GMRCR0,CMT_" Comment ("_USER_") continued.")
"RTN","GMRCP5D",54,0)
 .D SUB("H","COM",GMRCR0," ")
"RTN","GMRCP5D",55,0)
 .D BLD("COM",GMRCR0,1,0,"")
"RTN","GMRCP5D",56,0)
 .D BLD("COM",GMRCR0,1,0,$$CENTER("("_CMT_" Comment)"))
"RTN","GMRCP5D",57,0)
 .I $P(GMRC400,U,2)=17!($P(GMRC400,U,2)=25) D
"RTN","GMRCP5D",58,0)
 .. N FWDLN,FWDRS
"RTN","GMRCP5D",59,0)
 .. S FWDLN="Forwarded from: "
"RTN","GMRCP5D",60,0)
 .. S FWDRS=$P($G(^GMR(123,GMRCIFN,40,GMRCR0,3)),U)
"RTN","GMRCP5D",61,0)
 .. I $L(FWDRS) S FWDLN=FWDLN_FWDRS
"RTN","GMRCP5D",62,0)
 .. I '$L(FWDRS) S FWDLN=FWDLN_$$GET1^DIQ(123.5,+$P(GMRC400,U,6),.01)
"RTN","GMRCP5D",63,0)
 .. D BLD("COM",GMRCR0,1,5,FWDLN)
"RTN","GMRCP5D",64,0)
 .D BLD("COM",GMRCR0,1,5,USER)
"RTN","GMRCP5D",65,0)
 .D:($L(RPRV)) BLD("COM",GMRCR0,1,5,RPRV)
"RTN","GMRCP5D",66,0)
 .D:($L($G(GMRCISIT))) BLD("COM",GMRCR0,1,5,GMRCISIT)
"RTN","GMRCP5D",67,0)
 .;
"RTN","GMRCP5D",68,0)
 .N GMRCR2 S GMRCR2=0
"RTN","GMRCP5D",69,0)
 .F  S GMRCR2=$O(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2)) Q:'GMRCR2  D
"RTN","GMRCP5D",70,0)
 ..D BLD("COM",GMRCR0,1,0,$G(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2,0)))
"RTN","GMRCP5D",71,0)
 ;
"RTN","GMRCP5D",72,0)
 Q
"RTN","GMRCP5D",73,0)
 ;
"RTN","GMRCP5D",74,0)
ADDEND(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID) ;
"RTN","GMRCP5D",75,0)
 ;
"RTN","GMRCP5D",76,0)
 N GMRCADD,GMRCNDX,GMRCR1,GMRCV,TEXT,GMRCX
"RTN","GMRCP5D",77,0)
 ;
"RTN","GMRCP5D",78,0)
 S GMRCADD=0 F  S GMRCADD=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD)) Q:'GMRCADD  D
"RTN","GMRCP5D",79,0)
 .N GMRCSGNM,GMRCNMDT,GMRCTIT,GMRCMODE,GMRCCSDT,GMRCCTIT,GMRCCSGM
"RTN","GMRCP5D",80,0)
 .;
"RTN","GMRCP5D",81,0)
 .F GMRCV="GMRCSGNM","GMRCNMDT","GMRCTIT","GMRCMODE" D
"RTN","GMRCP5D",82,0)
 ..S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV))
"RTN","GMRCP5D",83,0)
 .;
"RTN","GMRCP5D",84,0)
 . F GMRCV="GMRCCSDT","GMRCCTIT","GMRCCSGM","GMRCCSIG" D
"RTN","GMRCP5D",85,0)
 .. S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV))
"RTN","GMRCP5D",86,0)
 .S GMRCNDX=$O(^TMP("GMRC",$J,"OUTPUT","RES"," "),-1)+1
"RTN","GMRCP5D",87,0)
 .I $L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" for "_GMRCRPT_" continued.")
"RTN","GMRCP5D",88,0)
 .I '$L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" continued.")
"RTN","GMRCP5D",89,0)
 .D SUB("H","RES",GMRCNDX," ")
"RTN","GMRCP5D",90,0)
 .I $L($G(GMRCSGNM)) D
"RTN","GMRCP5D",91,0)
 ..D SUB("F","RES",GMRCNDX," ")
"RTN","GMRCP5D",92,0)
 ..I (GMRCMODE="electronic") S GMRCX=" Addendum Signature: "_GMRCSGNM_" /es/ "_$$EXDT($G(GMRCNMDT))
"RTN","GMRCP5D",93,0)
 ..I '(GMRCMODE="electronic") S GMRCX=" Addendum Author: "_GMRCSGNM S:$L($G(GMRCNMDT)) GMRCX=GMRCX_" Last edited: "_$$EXDT(GMRCNMDT)
"RTN","GMRCP5D",94,0)
 ..D SUB("F","RES",GMRCNDX,GMRCX)
"RTN","GMRCP5D",95,0)
 ..D:$L($G(GMRCTIT)) SUB("F","RES",GMRCNDX,"                     "_GMRCTIT)
"RTN","GMRCP5D",96,0)
 .I $L($G(GMRCCSDT)) D
"RTN","GMRCP5D",97,0)
 ..D SUB("F","RES",GMRCNDX," ")
"RTN","GMRCP5D",98,0)
 ..I (GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT(GMRCCSDT)
"RTN","GMRCP5D",99,0)
 ..I '(GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /chart/ "_$$EXDT(GMRCCSDT)
"RTN","GMRCP5D",100,0)
 ..D SUB("F","RES",GMRCNDX,GMRCX)
"RTN","GMRCP5D",101,0)
 ..D:$L($G(GMRCCTIT)) SUB("F","RES",GMRCNDX,"                       "_GMRCCTIT)
"RTN","GMRCP5D",102,0)
 .D BLD("RES",GMRCNDX,1,0," ")
"RTN","GMRCP5D",103,0)
 .I $L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0_" FOR "_GMRCRPT))
"RTN","GMRCP5D",104,0)
 .I '$L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0))
"RTN","GMRCP5D",105,0)
 .D BLD("RES",GMRCNDX,1,0," ")
"RTN","GMRCP5D",106,0)
 .S GMRCR1=0 F  S GMRCR1=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1)) Q:'GMRCR1  D
"RTN","GMRCP5D",107,0)
 ..D BLD("RES",GMRCNDX,1,0,$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1,0)))
"RTN","GMRCP5D",108,0)
 Q
"RTN","GMRCP5D",109,0)
 ;
"RTN","GMRCP5D",110,0)
HDR ; Header code for form 513
"RTN","GMRCP5D",111,0)
 ;GMRCPEL   ext fmt Primary Eligibiity Code
"RTN","GMRCP5D",112,0)
 ;GMRCELIG  ext fmt of Patient Type defined @ FORMAT^GMRCP5A
"RTN","GMRCP5D",113,0)
 ;CVELIG    marker to indicate if pt has active preference for Combat Veteran Eligibility status
"RTN","GMRCP5D",114,0)
 ;get and format eligibility info
"RTN","GMRCP5D",115,0)
 N VAEL,VAPA,GMRCPEL,SUB,GMRCFROM
"RTN","GMRCP5D",116,0)
 N CVELIG ;WAT
"RTN","GMRCP5D",117,0)
 D ELIG^VADPT
"RTN","GMRCP5D",118,0)
 D ADD^VADPT
"RTN","GMRCP5D",119,0)
 N VASV,OEFOIF D SVC^VADPT S:(VASV(11)>0)!(VASV(12)>0)!(VASV(13)>0) OEFOIF="OEF/OIF" ;WAT 66
"RTN","GMRCP5D",120,0)
 S GMRCPEL=$P(VAEL(1),U,2)
"RTN","GMRCP5D",121,0)
 I $L($G(GMRCELIG))  D
"RTN","GMRCP5D",122,0)
 .;if TYPE is Active Duty and VETERAN Y/N? is No, then call the pt Active Duty
"RTN","GMRCP5D",123,0)
 .S:$P(VAEL(6),U,1)=5&(VAEL(4)=0) GMRCELIG=$P(VAEL(6),U,2)
"RTN","GMRCP5D",124,0)
 F SUB=0,1 D
"RTN","GMRCP5D",125,0)
 .N GMRCFLN
"RTN","GMRCP5D",126,0)
 .S GMRCFLN=$P($G(^DPT(GMRCDFN,0)),U,1)
"RTN","GMRCP5D",127,0)
 .S CVELIG=$$CVEDT^DGCV(GMRCDFN) S:$P($G(CVELIG),U,3) CVELIG="CV ELIGIBLE" ;WAT
"RTN","GMRCP5D",128,0)
 .D BLD("HDR",SUB,1,0,GMRCDVL)
"RTN","GMRCP5D",129,0)
 .D BLD("HDR",SUB,1,6,"MEDICAL RECORD")
"RTN","GMRCP5D",130,0)
 .D BLD("HDR",SUB,0,39,"|")
"RTN","GMRCP5D",131,0)
 .D BLD("HDR",SUB,0,45,"CONSULTATION SHEET")
"RTN","GMRCP5D",132,0)
 .D BLD("HDR",SUB,1,0,GMRCDVL)
"RTN","GMRCP5D",133,0)
 .D BLD("HDR",SUB,1,0,GMRCFLN)
"RTN","GMRCP5D",134,0)
 .D BLD("HDR",SUB,0,45,GMRCPEL)
"RTN","GMRCP5D",135,0)
 .D BLD("HDR",SUB,1,0,GMRCSN)
"RTN","GMRCP5D",136,0)
 .D BLD("HDR",SUB,0,16,$$EXDT(GMRCDOB))
"RTN","GMRCP5D",137,0)
 .D BLD("HDR",SUB,0,45,GMRCELIG)
"RTN","GMRCP5D",138,0)
 .D:$G(CVELIG)["CV" BLD("HDR",SUB,1,45,CVELIG)
"RTN","GMRCP5D",139,0)
 .D:$G(OEFOIF)="OEF/OIF" BLD("HDR",SUB,1,45,OEFOIF) ;WAT 66
"RTN","GMRCP5D",140,0)
 ;
"RTN","GMRCP5D",141,0)
 ;                                  ADDRESS LINES 1-3
"RTN","GMRCP5D",142,0)
 F GMRCX=1,2,3 D:$L(VAPA(GMRCX))
"RTN","GMRCP5D",143,0)
 .D BLD("HDR",0,1,0,VAPA(GMRCX))
"RTN","GMRCP5D",144,0)
 .;I GMRCX=1 D BLD("HDR",0,0,51,"Standard Form 513 (Rev 9-77)")
"RTN","GMRCP5D",145,0)
 ;
"RTN","GMRCP5D",146,0)
 ;         CITY              STATE                ZIP CODE
"RTN","GMRCP5D",147,0)
 S GMRCX=VAPA(4)_"   "_$P(VAPA(5),U,2)_"      "_VAPA(6)
"RTN","GMRCP5D",148,0)
 ;
"RTN","GMRCP5D",149,0)
 I $L(VAPA(8)) S GMRCX=GMRCX_"      Phone: "_VAPA(8)   ; TELEPHONE (IF AVAILABLE)
"RTN","GMRCP5D",150,0)
 ;
"RTN","GMRCP5D",151,0)
 D BLD("HDR",0,1,0,GMRCX)
"RTN","GMRCP5D",152,0)
 D BLD("HDR",0,1,0,GMRCDVL)
"RTN","GMRCP5D",153,0)
 D BLD("HDR",0,1,0,"Consult Request: "_$$CONSRQ(GMRCIFN))
"RTN","GMRCP5D",154,0)
 D BLD("HDR",0,1,55,"|Consult No.: "_GMRCIFN)
"RTN","GMRCP5D",155,0)
 ;
"RTN","GMRCP5D",156,0)
 D BLD("HDR",1,1,0,GMRCEQL)
"RTN","GMRCP5D",157,0)
 D BLD("HDR",0,1,0,GMRCDVL)
"RTN","GMRCP5D",158,0)
 ;
"RTN","GMRCP5D",159,0)
 I $G(CMT) D BLD("HDR",0,1,27,"("_$$PRCMT^GMRCP5B(CMT)_")") Q
"RTN","GMRCP5D",160,0)
 ;
"RTN","GMRCP5D",161,0)
 S GMRCFROM=$P($G(^SC(+$P(GMRCRD,U,6),0)),U,1)
"RTN","GMRCP5D",162,0)
 ;
"RTN","GMRCP5D",163,0)
 I '$L(GMRCFROM) D
"RTN","GMRCP5D",164,0)
 .N VAIN
"RTN","GMRCP5D",165,0)
 .D INP^VADPT
"RTN","GMRCP5D",166,0)
 .S GMRCFROM=$P($G(VAIN(4)),U,2)
"RTN","GMRCP5D",167,0)
 .I $L($G(VAIN(5))) S GMRCFROM=GMRCFROM_" (Rm/Bd: "_$G(VAIN(5))_" )"
"RTN","GMRCP5D",168,0)
 ;No location, IFC - consulting site
"RTN","GMRCP5D",169,0)
 I '$L(GMRCFROM),$P(GMRCRD,U,23),$P($G(GMRCRD(12)),U,5)="F" D
"RTN","GMRCP5D",170,0)
 .I $P(GMRCRD,U,21) S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,21),.01)
"RTN","GMRCP5D",171,0)
 .E  S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,23),.01)
"RTN","GMRCP5D",172,0)
 ;
"RTN","GMRCP5D",173,0)
 D BLD("HDR",0,1,0,"To: "_$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1))
"RTN","GMRCP5D",174,0)
 D BLD("HDR",0,1,5,"From: "_GMRCFROM)
"RTN","GMRCP5D",175,0)
 D BLD("HDR",0,0,49,"|Requested: "_$$EXDT($P(GMRCRD,U,7)))
"RTN","GMRCP5D",176,0)
 ;
"RTN","GMRCP5D",177,0)
 D BLD("HDR",0,1,0,GMRCDVL)
"RTN","GMRCP5D",178,0)
 D BLD("HDR",0,1,0,"Requesting Facility: "_$E(GMRCFAC,1,22))
"RTN","GMRCP5D",179,0)
 I $P(GMRCRD,U,11) D BLD("HDR",0,0,45,"|ATTENTION: "_$E($$GET1^DIQ(200,+$P(GMRCRD,U,11),.01),1,21))
"RTN","GMRCP5D",180,0)
 I $P(GMRCRD,U,23) D
"RTN","GMRCP5D",181,0)
 . D BLD("HDR",0,1,0,"Remote Consult No.: "_GMRCINO)
"RTN","GMRCP5D",182,0)
 . D BLD("HDR",0,1,0,"Role: "_GMRCIRL)
"RTN","GMRCP5D",183,0)
 D BLD("HDR",0,1,0,GMRCEQL)
"RTN","GMRCP5D",184,0)
 ;
"RTN","GMRCP5D",185,0)
 D KVAR^VADPT ;WAT 66
"RTN","GMRCP5D",186,0)
 Q
"RTN","GMRCP5D",187,0)
 ;
"RTN","GMRCP5D",188,0)
CENTER(X) ;
"RTN","GMRCP5D",189,0)
 ;
"RTN","GMRCP5D",190,0)
 N TEXT,COL
"RTN","GMRCP5D",191,0)
 S COL=35-($L(X)\2) Q:(COL<1) X
"RTN","GMRCP5D",192,0)
 S $E(TEXT,COL)=X
"RTN","GMRCP5D",193,0)
 Q TEXT
"RTN","GMRCP5D",194,0)
 ;
"RTN","GMRCP5D",195,0)
BLD(SUB,NDX,LINE,TAB,TEXT,RUNTIME) ;
"RTN","GMRCP5D",196,0)
 ;
"RTN","GMRCP5D",197,0)
 Q:'$L($G(SUB))
"RTN","GMRCP5D",198,0)
 N LINECNT
"RTN","GMRCP5D",199,0)
 ;
"RTN","GMRCP5D",200,0)
 F LINECNT=1:1:+LINE S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX)+1,0)=""
"RTN","GMRCP5D",201,0)
 ;
"RTN","GMRCP5D",202,0)
 S $E(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),0),TAB+1)=TEXT
"RTN","GMRCP5D",203,0)
 I $L($G(RUNTIME)) S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),1)=RUNTIME
"RTN","GMRCP5D",204,0)
 ;
"RTN","GMRCP5D",205,0)
 S GMRCLAST=SUB
"RTN","GMRCP5D",206,0)
 Q
"RTN","GMRCP5D",207,0)
 ;
"RTN","GMRCP5D",208,0)
SUB(ZONE,SUB,NDX,TEXT) ;
"RTN","GMRCP5D",209,0)
 ;
"RTN","GMRCP5D",210,0)
 N NEXT
"RTN","GMRCP5D",211,0)
 S NEXT=$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE," "),-1)+1
"RTN","GMRCP5D",212,0)
 S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE,NEXT,0)=TEXT
"RTN","GMRCP5D",213,0)
 Q
"RTN","GMRCP5D",214,0)
 ;
"RTN","GMRCP5D",215,0)
LASTLN(SUB,NDX) ;
"RTN","GMRCP5D",216,0)
 Q +$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX," "),-1)
"RTN","GMRCP5D",217,0)
 ;
"RTN","GMRCP5D",218,0)
CONSRQ(IFN) ;
"RTN","GMRCP5D",219,0)
 ;
"RTN","GMRCP5D",220,0)
 N PTR,LINK,REF,GMRCRQ
"RTN","GMRCP5D",221,0)
 I +$P(^GMR(123,+IFN,0),U,8) D
"RTN","GMRCP5D",222,0)
 . S GMRCRQ=$P(^GMR(123,+IFN,0),U,8)
"RTN","GMRCP5D",223,0)
 . S GMRCRQ=$$GET1^DIQ(123.3,+GMRCRQ,.01)
"RTN","GMRCP5D",224,0)
 . I '$L(GMRCRQ) S GMRCRQ="Procedure"
"RTN","GMRCP5D",225,0)
 I $L($G(GMRCRQ)) Q GMRCRQ
"RTN","GMRCP5D",226,0)
 I $L($G(^GMR(123,IFN,1.11))) D
"RTN","GMRCP5D",227,0)
 . N SERV,TYPE
"RTN","GMRCP5D",228,0)
 . S SERV=$$UP^XLFSTR($$GET1^DIQ(123.5,$P(^GMR(123,IFN,0),U,5),.01))
"RTN","GMRCP5D",229,0)
 . S TYPE=$$UP^XLFSTR(^GMR(123,IFN,1.11)) I TYPE'=SERV D
"RTN","GMRCP5D",230,0)
 . I TYPE'=SERV S GMRCRQ=$E(^GMR(123,IFN,1.11),1,36)
"RTN","GMRCP5D",231,0)
 Q:$L($G(GMRCRQ)) GMRCRQ Q "Consult"
"RTN","GMRCP5D",232,0)
 ;
"RTN","GMRCP5D",233,0)
EXDT(X) ;EXTERNAL DATE FORMAT
"RTN","GMRCP5D",234,0)
 ;
"RTN","GMRCP5D",235,0)
 N DATE,TIME,HR,MN,PD,Y,%DT
"RTN","GMRCP5D",236,0)
 Q:'$L(X) ""
"RTN","GMRCP5D",237,0)
 I '(X?7N.1".".6N) S %DT="PTS" D ^%DT S X=Y
"RTN","GMRCP5D",238,0)
 Q $$FMTE^XLFDT(X,"5PMZ")
"RTN","GMRCP5D",239,0)
 ;
"RTN","GMRCSLM2")
0^9^B77652080
"RTN","GMRCSLM2",1,0)
GMRCSLM2 ;SLC/DCM,WAT - LM Detailed  display and printing ;04/22/09  11:51
"RTN","GMRCSLM2",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,18,15,17,23,22,65,66**;DEC 27,1997;Build 30
"RTN","GMRCSLM2",3,0)
 ;
"RTN","GMRCSLM2",4,0)
 ;This routine invokes IA #872 ^ORD(101   #875 ORDER STATUS file point   #2467 $$OI^ORX8   #2638 ORDER STATUS file access
"RTN","GMRCSLM2",5,0)
 ;#2056 $$GET1^DIQ   #10104 XLFSTR   #4156 $$CVEDT^DGCV   #10117  ^VALM10   #2849 ORDERS file
"RTN","GMRCSLM2",6,0)
 ;#10040 HOSPITAL LOCATION file   #10060 NEW PERSON file  #4807 RDIS^DGRPDB
"RTN","GMRCSLM2",7,0)
 ;
"RTN","GMRCSLM2",8,0)
DT(GMRCO,GMRCIERR) ;;Entry point to set-up detailed display.
"RTN","GMRCSLM2",9,0)
 ;;Pass in GMRCO as +GMRCO - a number only. GMRCO=IEN from of consult from file 123
"RTN","GMRCSLM2",10,0)
 ;;Results are placed in ^TMP("GMRCR",$J,"DT",
"RTN","GMRCSLM2",11,0)
 ;;Pass in variable GMRCOER=2 if calling from the GUI, GMRCOER=1 if call is from CPRS consults tab
"RTN","GMRCSLM2",12,0)
 ;;Pass in variable GMRCOER=0 (or as <UNDEFINED>) if call is from consults routines
"RTN","GMRCSLM2",13,0)
 K GMRCQUT
"RTN","GMRCSLM2",14,0)
 N DFN,GMRCD,GMRCDA,ORIFN,GMRCSF S GMRCDVDL="",$P(GMRCDVDL,"-",80)=""
"RTN","GMRCSLM2",15,0)
 I $S('GMRCO:1,'$D(^GMR(123,+GMRCO,0)):1,1:0) D:$S('$D(GMRCOER):1,'GMRCOER:1,1:0)  S GMRCQUT=1 Q
"RTN","GMRCSLM2",16,0)
 .S GMRCMSG="The consult entry selected for the Detailed Display is unknown." D EXAC^GMRCADC(GMRCMSG) K GMRCMSG
"RTN","GMRCSLM2",17,0)
 .Q
"RTN","GMRCSLM2",18,0)
 K ^TMP("GMRCR",$J,"DT") S TAB="",$P(TAB," ",30)="",GMRCCT=1
"RTN","GMRCSLM2",19,0)
 S GMRCO(0)=^GMR(123,+GMRCO,0),ORIFN=$P(GMRCO(0),"^",3),DFN=$P(GMRCO(0),"^",2)
"RTN","GMRCSLM2",20,0)
 S X="SDUTL3" X ^%ZOSF("TEST") I  D
"RTN","GMRCSLM2",21,0)
 .N PR S PR=$$OUTPTPR^SDUTL3(DFN) I $L(PR) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Current PC Provider:   "_$P(PR,"^",2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",22,0)
 .S PR=$$OUTPTTM^SDUTL3(DFN) I $L(PR) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Current PC Team:       "_$P(PR,"^",2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",23,0)
 .Q
"RTN","GMRCSLM2",24,0)
 N VAIN,VAEL,CVELIG
"RTN","GMRCSLM2",25,0)
 D INP^VADPT S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Current Pat. Status:   "_$S(+VAIN(8):"Inpatient",1:"Outpatient"),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",26,0)
 I $D(VAIN(4)),$L($P(VAIN(4),"^",2)) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Ward:"_$E(TAB,1,18)_$P(VAIN(4),"^",2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",27,0)
 D ELIG^VADPT
"RTN","GMRCSLM2",28,0)
 S:$L($P(VAEL(1),"^",2)) ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Primary Eligibility:"_$E(TAB,1,3)_$P(VAEL(1),"^",2)_$S(VAEL(8)']"":" (NOT VERIFIED)",1:"("_$P(VAEL(8),"^",2)_")"),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",29,0)
 ;wat 66
"RTN","GMRCSLM2",30,0)
 I $L($P(VAEL(6),U,2))  D
"RTN","GMRCSLM2",31,0)
 .;if TYPE is Active Duty and VETERAN Y/N? is No, then call the pt Active Duty
"RTN","GMRCSLM2",32,0)
 .I $P(VAEL(6),U,1)=5&(VAEL(4)=0) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Patient Type:"_$E(TAB,1,10)_$P(VAEL(6),U,2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",33,0)
 .E  S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Patient Type:"_$E(TAB,1,10)_$P(VAEL(6),U,2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",34,0)
 ;//wat 66
"RTN","GMRCSLM2",35,0)
 S CVELIG=$$CVEDT^DGCV(DFN) S:$P($G(CVELIG),U,3) ^TMP("GMRCR",$J,"DT",GMRCCT,0)="CV Eligible:"_$E(TAB,1,11)_"YES",GMRCCT=GMRCCT+1 ;WAT
"RTN","GMRCSLM2",36,0)
 ;wat 66
"RTN","GMRCSLM2",37,0)
 N VASV,OIFOEF S OIFOEF="NO" D SVC^VADPT S:(VASV(11)>0)!(VASV(12)>0)!(VASV(13)>0) OIFOEF="YES"
"RTN","GMRCSLM2",38,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="OEF/OIF: "_$E(TAB,1,14)_$G(OIFOEF),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",39,0)
 ; GET SC RATINGS AND %
"RTN","GMRCSLM2",40,0)
 N INC,COND S INC=0
"RTN","GMRCSLM2",41,0)
 I $P(VAEL(3),U)=1  D
"RTN","GMRCSLM2",42,0)
 .S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",43,0)
 .S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Service Connection/Rated Disabilities",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",44,0)
 .I '$P(VAEL(3),U,2) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="SC Percent:"_$E(TAB,1,12)_"DATA NOT FOUND",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",45,0)
 .E  S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="SC Percent:"_$E(TAB,1,12)_$P(VAEL(3),U,2)_"%",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",46,0)
 .D RDIS^DGRPDB(DFN,.GMRCRDIS) I $D(GMRCRDIS(1))  D
"RTN","GMRCSLM2",47,0)
 ..F  S INC=$O(GMRCRDIS(INC)) Q:INC=""  D
"RTN","GMRCSLM2",48,0)
 ...S COND=$$GET1^DIQ(31,$P(GMRCRDIS(INC),U),.01)
"RTN","GMRCSLM2",49,0)
 ...S:$G(INC)=1 ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Rated Disabilities:"_$E(TAB,1,4)_$G(COND)_"  ("_$P(GMRCRDIS(INC),U,2)_"%)",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",50,0)
 ...S:$G(INC)>1 ^TMP("GMRCR",$J,"DT",GMRCCT,0)=$E(TAB,1,23)_$G(COND)_"  ("_$P(GMRCRDIS(INC),U,2)_"%)",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",51,0)
 .I '$D(GMRCRDIS)  D
"RTN","GMRCSLM2",52,0)
 ..S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Rated Disabilities:"_$E(TAB,1,4)_"NONE STATED",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",53,0)
 ;//wat 66
"RTN","GMRCSLM2",54,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",55,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Order Information",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",56,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="To Service:"_$E(TAB,1,12)_$P($G(^GMR(123.5,+$P(GMRCO(0),"^",5),0)),"^"),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",57,0)
 I $P(GMRCO(0),"^",11) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Attention:"_$E(TAB,1,13)_$$GET1^DIQ(200,$P($G(GMRCO(0)),"^",11),.01),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",58,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="From Service:"_$E(TAB,1,10)_$P($G(^SC(+$P(GMRCO(0),"^",6),0)),"^"),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",59,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Requesting Provider: "_$E(TAB,1,2)_$S($P(GMRCO(0),"^",14)]"":$$GET1^DIQ(200,$P($G(GMRCO(0)),"^",14),.01),1:""),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",60,0)
 I $L($P(GMRCO(0),"^",18)) D
"RTN","GMRCSLM2",61,0)
 .S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Service is to be rendered on an "_$S($P(GMRCO(0),"^",18)="I":"INPATIENT",1:"OUTPATIENT")_" basis",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",62,0)
 .Q
"RTN","GMRCSLM2",63,0)
 I $P(GMRCO(0),"^",10) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Place:"_$E(TAB,1,17)_$P($G(^ORD(101,+$P(GMRCO(0),"^",10),0)),"^",2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",64,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Urgency:"_$E(TAB,1,15)_$S($L($P(GMRCO(0),"^",9)):$P($G(^ORD(101,+$P(GMRCO(0),"^",9),0)),"^",2),1:""),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",65,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Earliest Appr. Date:"_$E(TAB,1,3)_$$FMTE^XLFDT($P($G(GMRCO(0)),"^",24),1),GMRCCT=GMRCCT+1 ;WAT/66
"RTN","GMRCSLM2",66,0)
 S X="ORX8" X ^%ZOSF("TEST") I  D
"RTN","GMRCSLM2",67,0)
 .N GMRCOITM S GMRCOITM=$$OI^ORX8(ORIFN)
"RTN","GMRCSLM2",68,0)
 .S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Orderable Item:"_$E(TAB,1,8)_$P(GMRCOITM,U,2),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",69,0)
 .Q
"RTN","GMRCSLM2",70,0)
 S GMRCPRNM=$P(GMRCO(0),"^",8),GMRCPROC=$S(+GMRCPRNM:$P($G(^GMR(123.3,+GMRCPRNM,0)),"^"),1:"Consult Request")
"RTN","GMRCSLM2",71,0)
 I $L(GMRCPROC) D
"RTN","GMRCSLM2",72,0)
 .N GMRCLN
"RTN","GMRCSLM2",73,0)
 .S GMRCTYPE=$S($P(GMRCO(0),U,17)="P":"Procedure",1:"Consult")
"RTN","GMRCSLM2",74,0)
 .S GMRCLN=GMRCTYPE_":"_$E(TAB,1,22-$L(GMRCTYPE))_GMRCPROC
"RTN","GMRCSLM2",75,0)
 .S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=GMRCLN
"RTN","GMRCSLM2",76,0)
 .S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",77,0)
 .I $G(^GMR(123,+GMRCO,1)) D
"RTN","GMRCSLM2",78,0)
 .. S GMRCLN=""
"RTN","GMRCSLM2",79,0)
 .. S GMRCLN="Clinical Procedure:"_$E(TAB,1,4)
"RTN","GMRCSLM2",80,0)
 .. S GMRCLN=GMRCLN_$$GET1^DIQ(123,+GMRCO,1.01,"E")
"RTN","GMRCSLM2",81,0)
 .. S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=GMRCLN
"RTN","GMRCSLM2",82,0)
 .. S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",83,0)
 .Q
"RTN","GMRCSLM2",84,0)
 S GMRCD=$G(^GMR(123,+GMRCO,30)) I $L(GMRCD) D
"RTN","GMRCSLM2",85,0)
 . I $L(GMRCD)>54 D
"RTN","GMRCSLM2",86,0)
 .. N SEG,I S I=2
"RTN","GMRCSLM2",87,0)
 .. F  S SEG=$P(GMRCD," ",1,I) Q:$L(SEG)>54  S I=I+1
"RTN","GMRCSLM2",88,0)
 .. S SEG=$P(GMRCD," ",1,(I-1))
"RTN","GMRCSLM2",89,0)
 .. S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Provisional Diagnosis: "_SEG
"RTN","GMRCSLM2",90,0)
 .. S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",91,0)
 .. S SEG=$$REPEAT^XLFSTR(" ",22)_$E(GMRCD,$L(SEG)+1,80)
"RTN","GMRCSLM2",92,0)
 .. S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=SEG S GMRCD=""
"RTN","GMRCSLM2",93,0)
 .. S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",94,0)
 I GMRCD'="" D
"RTN","GMRCSLM2",95,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Provisional Diagnosis: "_GMRCD
"RTN","GMRCSLM2",96,0)
 . S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",97,0)
 I $D(^GMR(123,+GMRCO,20,0)) D
"RTN","GMRCSLM2",98,0)
 .I $O(^GMR(123,+GMRCO,20,0)) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Reason For Request:",GMRCCT=GMRCCT+1 D  Q
"RTN","GMRCSLM2",99,0)
 .. S LN=0
"RTN","GMRCSLM2",100,0)
 .. F  S LN=$O(^GMR(123,+GMRCO,20,LN)) Q:LN=""  D
"RTN","GMRCSLM2",101,0)
 ... S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=^GMR(123,+GMRCO,20,LN,0)
"RTN","GMRCSLM2",102,0)
 ... I $G(GMRCIERR) D
"RTN","GMRCSLM2",103,0)
 .... N TXT S TXT=^TMP("GMRCR",$J,"DT",GMRCCT,0)_"..."
"RTN","GMRCSLM2",104,0)
 .... S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=TXT
"RTN","GMRCSLM2",105,0)
 .... S LN=9999 ;quit with just one line
"RTN","GMRCSLM2",106,0)
 ... S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",107,0)
 .. Q
"RTN","GMRCSLM2",108,0)
 . Q
"RTN","GMRCSLM2",109,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=" ",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",110,0)
 ; get inter-facility consult info
"RTN","GMRCSLM2",111,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Inter-facility Information",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",112,0)
 I '$P(GMRCO(0),"^",23) D
"RTN","GMRCSLM2",113,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="This is not an inter-facility consult request.",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",114,0)
 E  D
"RTN","GMRCSLM2",115,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=$$REPEAT^XLFSTR("-",27)
"RTN","GMRCSLM2",116,0)
 . S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",117,0)
 . N GMRCOP
"RTN","GMRCSLM2",118,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Remote Facility:"_$E(TAB,1,6)_$P($G(^DIC(4,+$P(GMRCO(0),"^",23),0)),"^"),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",119,0)
 . S GMRCO(12)=$G(^GMR(123,+GMRCO,12))
"RTN","GMRCSLM2",120,0)
 . I $L($P(GMRCO(12),U,6)) D
"RTN","GMRCSLM2",121,0)
 .. S GMRCOP=$P(GMRCO(12),U,6)
"RTN","GMRCSLM2",122,0)
 . I '$D(GMRCOP) S GMRCOP=$$GET1^DIQ(200,+$P(GMRCO(0),U,14),.01)
"RTN","GMRCSLM2",123,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Ordering Provider:"_$E(TAB,1,5)_GMRCOP,GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",124,0)
 . S GMRCO(13)=$G(^GMR(123,+GMRCO,13)) I $L($P(GMRCO(13),U,2,3))>1 D
"RTN","GMRCSLM2",125,0)
 .. N LINE
"RTN","GMRCSLM2",126,0)
 .. S LINE=$P(GMRCO(13),U,2) I $L(LINE) S LINE=LINE_$E(TAB,1,5) D
"RTN","GMRCSLM2",127,0)
 ... S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Ordering Provider phone: "_LINE
"RTN","GMRCSLM2",128,0)
 ... S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",129,0)
 .. S LINE=$P(GMRCO(13),U,3) I $L(LINE) S LINE=LINE_$E(TAB,1,5) D
"RTN","GMRCSLM2",130,0)
 ... S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Ordering Provider pager: "_LINE
"RTN","GMRCSLM2",131,0)
 ... S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",132,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Remote Consult #"_$E(TAB)_$P(GMRCO(0),"^",22),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",133,0)
 . I $L($P(GMRCO(13),U)) S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Remote Service name: "_$E(TAB)_$P(GMRCO(13),U),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",134,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Role: "_$E(TAB,1,10)_$S($P(GMRCO(12),U,5)="P":"Requesting facility",1:"Consulting facility"),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",135,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",136,0)
 ;get status, last action, and significant findings
"RTN","GMRCSLM2",137,0)
 S STS=$P(GMRCO(0),"^",12),^TMP("GMRCR",$J,"DT",GMRCCT,0)="Status:  "_$E(TAB,1,14)_$S($D(^ORD(100.01,+STS,0)):$P(^(0),"^",1),1:$P(^ORD(100.01,6,0),"^",1)),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",138,0)
 S GMRCA=$P(^GMR(123,+GMRCO,0),"^",13),^TMP("GMRCR",$J,"DT",GMRCCT,0)="Last Action:"_$E(TAB,1,11)_$S(+GMRCA:$P($G(^GMR(123.1,GMRCA,0)),"^",1),1:""),GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",139,0)
 I $L($P(GMRCO(0),"^",19)) D
"RTN","GMRCSLM2",140,0)
 .S GMRCSF=$P(GMRCO(0),"^",19)
"RTN","GMRCSLM2",141,0)
 .S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Significant Findings:  "_$S(GMRCSF="Y":"YES",GMRCSF="N":"NO",1:"Unknown")
"RTN","GMRCSLM2",142,0)
 .S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",143,0)
 .Q
"RTN","GMRCSLM2",144,0)
 I $G(GMRCIERR) Q  ;don't need results or activities on IFC errors
"RTN","GMRCSLM2",145,0)
 D ACTLOG^GMRCSLM4(+GMRCO)
"RTN","GMRCSLM2",146,0)
 ; any inter-facility results?
"RTN","GMRCSLM2",147,0)
 I $P(GMRCO(0),"^",23) D
"RTN","GMRCSLM2",148,0)
 . N GMRCIFRS,X S GMRCIFRS=0,X=""
"RTN","GMRCSLM2",149,0)
 . F  S X=$O(^GMR(123,GMRCO,51,"B",X)) Q:X=""  S GMRCIFRS=GMRCIFRS+1
"RTN","GMRCSLM2",150,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="",GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",151,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="Inter-facility Results: "_$S(GMRCIFRS>0:"Results are available via Display Results action.",1:"No results available for this consult request."),GMRCCT=GMRCCT+2
"RTN","GMRCSLM2",152,0)
 ;get local results
"RTN","GMRCSLM2",153,0)
 D GETRSLT^GMRCART($NA(^TMP("GMRCRT",$J)),1)
"RTN","GMRCSLM2",154,0)
 N NXT S NXT=0
"RTN","GMRCSLM2",155,0)
 F  S NXT=$O(^TMP("GMRCRT",$J,NXT)) Q:'NXT  D
"RTN","GMRCSLM2",156,0)
 . S ^TMP("GMRCR",$J,"DT",GMRCCT,0)=$G(^TMP("GMRCRT",$J,NXT,0))
"RTN","GMRCSLM2",157,0)
 . S GMRCCT=GMRCCT+1
"RTN","GMRCSLM2",158,0)
 . Q
"RTN","GMRCSLM2",159,0)
 K ^TMP("GMRCRT",$J)
"RTN","GMRCSLM2",160,0)
 I $S('$D(GMRCOER):1,'GMRCOER:1,1:0),$D(VALMAR) D CLEAN^VALM10
"RTN","GMRCSLM2",161,0)
 S ^TMP("GMRCR",$J,"DT",GMRCCT,0)="",$P(^(0),"=",80)="",^(0)=$E(^(0),1,36)_" END "_$E(^(0),43,80)
"RTN","GMRCSLM2",162,0)
DTQ K X,LN,PL,TO,WP,FLG,SEX,STS,URG,WRD,BKLN,DATA,WRD,PROC,LINE,GMRCD,GMRCDVDL,GMRCO,GMRCAR,GMRCRB,GMRCLA,GMRCSR,GMRCTO,MCFILE,MCPROC,DSPLINE,GMRCLA1,GMRCPRNM,GMRCPROC,GMRCTYPE,GMRCWARD
"RTN","GMRCSLM2",163,0)
 I $D(GMRCOER),'GMRCOER D:$D(VALMEVL) KILL^VALM10() D:$D(VALMAR) CLEAN^VALM10
"RTN","GMRCSLM2",164,0)
 Q
"RTN","GMRCSTL8")
0^20^B111506461
"RTN","GMRCSTL8",1,0)
GMRCSTL8 ;SLC/JFR/WAT - Totals format for CPM ;06/01/09  12:57
"RTN","GMRCSTL8",2,0)
 ;;3.0;CONSULT/REQUEST TRACKING;**41,60,66**;DEC 27, 1997;Build 30
"RTN","GMRCSTL8",3,0)
 ; This routine invokes ICRs
"RTN","GMRCSTL8",4,0)
 ; 875 (file 100.01), 2638 (file 100.01),10104 (XLFSTR),10103 (XLFDT),3744 (VADPT)
"RTN","GMRCSTL8",5,0)
 ;
"RTN","GMRCSTL8",6,0)
 ; portions copied from GMRCSTL1 & GMRCSTL2
"RTN","GMRCSTL8",7,0)
 ;patch 66 - CHKRNG updated location referenced for Earliest Appropriate Date field; this was changed during v28 development.
"RTN","GMRCSTL8",8,0)
 Q  ; can't start here
"RTN","GMRCSTL8",9,0)
PRTTOT(GEN,INDEX,NAME,ARRN) ; totals for printed report
"RTN","GMRCSTL8",10,0)
 N QUIT S QUIT=0 D NOACTVT Q:QUIT=1
"RTN","GMRCSTL8",11,0)
 N GMRCPCT,LAYOUT,FRMT,ROWTEXT,CALC1,CALC2,CALC3,ROWTXT
"RTN","GMRCSTL8",12,0)
 N COUNT,SVCUSG
"RTN","GMRCSTL8",13,0)
 S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1)
"RTN","GMRCSTL8",14,0)
 I GEN=2 D
"RTN","GMRCSTL8",15,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=""
"RTN","GMRCSTL8",16,0)
 .S SVCUSG=$P(^GMR(123.5,INDEX,0),U,2) I $G(SVCUSG) S NAME=NAME_$S(SVCUSG=1:" <grouper only>",SVCUSG=2:"   <disabled>",1:"")
"RTN","GMRCSTL8",17,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="     GROUPER: "_NAME_" Totals:"
"RTN","GMRCSTL8",18,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("WITHIN     IFC     IFC",75)
"RTN","GMRCSTL8",19,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("FACILITY   SENT    REC'D",77)
"RTN","GMRCSTL8",20,0)
 I GEN=1 D
"RTN","GMRCSTL8",21,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=" "
"RTN","GMRCSTL8",22,0)
 .I $P(^GMR(123.5,INDEX,0),U,2)=9 S NAME=NAME_"   <disabled>"
"RTN","GMRCSTL8",23,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="SERVICE: "_NAME
"RTN","GMRCSTL8",24,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("WITHIN     IFC      IFC",76)
"RTN","GMRCSTL8",25,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("FACILITY   SENT     REC'D",78)
"RTN","GMRCSTL8",26,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13),9)
"RTN","GMRCSTL8",27,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 30 Days Before Start/End of Qtr:"_ROWTXT
"RTN","GMRCSTL8",28,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14),9)
"RTN","GMRCSTL8",29,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 60 Days Before Start/End of Qtr:"_ROWTXT
"RTN","GMRCSTL8",30,0)
 I GEN=2 D
"RTN","GMRCSTL8",31,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13),9)
"RTN","GMRCSTL8",32,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 30 Days Before Start/End of Qtr:"_ROWTXT
"RTN","GMRCSTL8",33,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14),9)
"RTN","GMRCSTL8",34,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 60 Days Before Start/End of Qtr:"_ROWTXT
"RTN","GMRCSTL8",35,0)
 I GEN=1!(GEN=2) D
"RTN","GMRCSTL8",36,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,3),12)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,9),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,15),9)
"RTN","GMRCSTL8",37,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="Complete with Results in 30 Days of Request:"_ROWTXT
"RTN","GMRCSTL8",38,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,4),12)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,10),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,16),9)
"RTN","GMRCSTL8",39,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="Complete with Results 31-60 Days of Request:"_ROWTXT
"RTN","GMRCSTL8",40,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17),9)
"RTN","GMRCSTL8",41,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests Created 60 Days Before Qtr Start:"_ROWTXT
"RTN","GMRCSTL8",42,0)
 .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,6),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,12),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,18),9)
"RTN","GMRCSTL8",43,0)
 .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests Pending 60 Days Before Qtr Start:"_ROWTXT
"RTN","GMRCSTL8",44,0)
 .;% complete in 30 days of request
"RTN","GMRCSTL8",45,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,3)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U))*100,2,2)_"%"
"RTN","GMRCSTL8",46,0)
 .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1)
"RTN","GMRCSTL8",47,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,9)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7))*100,2,2)_"%"
"RTN","GMRCSTL8",48,0)
 .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2)
"RTN","GMRCSTL8",49,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,15)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13))*100,2,2)_"%"
"RTN","GMRCSTL8",50,0)
 .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3)
"RTN","GMRCSTL8",51,0)
 .S COUNT=COUNT+1
"RTN","GMRCSTL8",52,0)
 .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Complete w/Results in 30 Days of Request: "_ROWTXT
"RTN","GMRCSTL8",53,0)
 .;% complete in 60 days of request
"RTN","GMRCSTL8",54,0)
 .K CALC1,CALC2,CALC3
"RTN","GMRCSTL8",55,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,4)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2))*100,2,2)_"%"
"RTN","GMRCSTL8",56,0)
 .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1)
"RTN","GMRCSTL8",57,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,10)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8))*100,2,2)_"%"
"RTN","GMRCSTL8",58,0)
 .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2)
"RTN","GMRCSTL8",59,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,16)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14))*100,2,2)_"%"
"RTN","GMRCSTL8",60,0)
 .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3)
"RTN","GMRCSTL8",61,0)
 .S COUNT=COUNT+1
"RTN","GMRCSTL8",62,0)
 .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Complete w/Results 31-60 Days of Request: "_ROWTXT
"RTN","GMRCSTL8",63,0)
 .;% pending before quarter start
"RTN","GMRCSTL8",64,0)
 .K CALC1,CALC2,CALC3
"RTN","GMRCSTL8",65,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,6)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5))*100,2,2)_"%"
"RTN","GMRCSTL8",66,0)
 .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1)
"RTN","GMRCSTL8",67,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,12)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11))*100,2,2)_"%"
"RTN","GMRCSTL8",68,0)
 .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2)
"RTN","GMRCSTL8",69,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,18)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17))*100,2,2)_"%"
"RTN","GMRCSTL8",70,0)
 .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3)
"RTN","GMRCSTL8",71,0)
 .S COUNT=COUNT+1
"RTN","GMRCSTL8",72,0)
 .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Still Pending Created Before Qtr Start:   "_ROWTXT
"RTN","GMRCSTL8",73,0)
 Q
"RTN","GMRCSTL8",74,0)
DELTOT(GEN,INDEX,NAME,ARRN) ; format for delimited
"RTN","GMRCSTL8",75,0)
 N QUIT S QUIT=0 D NOACTVT Q:QUIT=1
"RTN","GMRCSTL8",76,0)
 N STRING,COUNT,PIECE,INCR,SVCUSG
"RTN","GMRCSTL8",77,0)
 S SVCUSG=$P(^GMR(123.5,INDEX,0),U,2) I $G(SVCUSG) S NAME=NAME_$S(SVCUSG=1:" <grouper only>",SVCUSG=2:" <disabled>",1:"")
"RTN","GMRCSTL8",78,0)
 S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1),STRING=$S(GEN=2:"GROUPER: ",1:"")_NAME_";"
"RTN","GMRCSTL8",79,0)
 F PIECE=1:1:18 D
"RTN","GMRCSTL8",80,0)
 .S STRING=STRING_$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,PIECE)_";"
"RTN","GMRCSTL8",81,0)
 .I PIECE=6!(PIECE=12)!(PIECE=18) D
"RTN","GMRCSTL8",82,0)
 ..S INCR=$S(PIECE=6:0,PIECE=12:6,1:12)
"RTN","GMRCSTL8",83,0)
 ..;percents
"RTN","GMRCSTL8",84,0)
 ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(1+INCR))=0 S STRING=STRING_"N/A;"
"RTN","GMRCSTL8",85,0)
 ..E  S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(3+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(1+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";"
"RTN","GMRCSTL8",86,0)
 ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(2+INCR))=0 S STRING=STRING_"N/A;"
"RTN","GMRCSTL8",87,0)
 ..E  S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(4+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(2+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";"
"RTN","GMRCSTL8",88,0)
 ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(5+INCR))=0 S STRING=STRING_"N/A;"
"RTN","GMRCSTL8",89,0)
 ..E  S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(6+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(5+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";"
"RTN","GMRCSTL8",90,0)
 S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=STRING
"RTN","GMRCSTL8",91,0)
 Q
"RTN","GMRCSTL8",92,0)
NOACTVT ;services with no activity for the reporting period
"RTN","GMRCSTL8",93,0)
 N CONT,PIECE S CONT=1
"RTN","GMRCSTL8",94,0)
 I GEN=1&($P(^GMR(123.5,INDEX,0),U,2)=1) S QUIT=1 Q  ;;don't add to list if service is a grouper only...
"RTN","GMRCSTL8",95,0)
 F PIECE=1:1:18 D  Q:CONT=0
"RTN","GMRCSTL8",96,0)
 .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,PIECE)>0 S CONT=0 Q
"RTN","GMRCSTL8",97,0)
 S:CONT=1 ^TMP("GMRCT",$J,0,NAME)="",QUIT=1
"RTN","GMRCSTL8",98,0)
 Q
"RTN","GMRCSTL8",99,0)
ONESTAT(ARRN,SVCN,STAT,DT1,DT2,STR) ;Process one status
"RTN","GMRCSTL8",100,0)
 ;Input -- ARRN  "CP"  - to be printed  or "DEL" - in delimited format
"RTN","GMRCSTL8",101,0)
 ;SVCN = node in ^TMP("GMRCLIST,$J..STAT = status being worked on..DT1 = starting date..DT2 = ending date
"RTN","GMRCSTL8",102,0)
 ;STR = string value used to store 30/60 day results in correct piece of ^tmp arrays
"RTN","GMRCSTL8",103,0)
 ;Output - None
"RTN","GMRCSTL8",104,0)
 N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP,GMRCQT,FLG,TYPE
"RTN","GMRCSTL8",105,0)
 S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1)
"RTN","GMRCSTL8",106,0)
 S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2)
"RTN","GMRCSTL8",107,0)
 S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3)
"RTN","GMRCSTL8",108,0)
 S GMRCXDT=9999999-DT2-.6  ;start searching the global at a date a fraction newer than DT2 (the end date for this search)
"RTN","GMRCSTL8",109,0)
 F  S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT=""!(GMRCXDT>(9999999-DT1))  D
"RTN","GMRCSTL8",110,0)
 .S GMRCPT=0
"RTN","GMRCSTL8",111,0)
 .;Loop for one consult at a time
"RTN","GMRCSTL8",112,0)
 .F  S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT=""  D
"RTN","GMRCSTL8",113,0)
 ..S FLG=0 D EXCLUDE Q:$G(FLG)=1
"RTN","GMRCSTL8",114,0)
 ..S TYPE="" D REQTYPE
"RTN","GMRCSTL8",115,0)
 ..I TYPE="LOCAL" D  ;set totals for 30 and 60 day range
"RTN","GMRCSTL8",116,0)
 ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U)+1
"RTN","GMRCSTL8",117,0)
 ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,2)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,2)+1
"RTN","GMRCSTL8",118,0)
 ...I STAT=2 D
"RTN","GMRCSTL8",119,0)
 ....Q:'$O(^GMR(123,+$G(GMRCPT),50,0))  ;Q if no results
"RTN","GMRCSTL8",120,0)
 ....D CHKRNG
"RTN","GMRCSTL8",121,0)
 ..I TYPE="IFCP" D
"RTN","GMRCSTL8",122,0)
 ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,7)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,7)+1
"RTN","GMRCSTL8",123,0)
 ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,8)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,8)+1
"RTN","GMRCSTL8",124,0)
 ...D:STAT=2 CHKRNG
"RTN","GMRCSTL8",125,0)
 ..I TYPE="IFCF" D
"RTN","GMRCSTL8",126,0)
 ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,13)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,13)+1
"RTN","GMRCSTL8",127,0)
 ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,14)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,14)+1
"RTN","GMRCSTL8",128,0)
 ...D:STAT=2 CHKRNG
"RTN","GMRCSTL8",129,0)
 Q
"RTN","GMRCSTL8",130,0)
 ;
"RTN","GMRCSTL8",131,0)
ONESTAT2(ARRN,SVCN,STAT,DT1) ;all statuses, all requests, before quarter start
"RTN","GMRCSTL8",132,0)
 ;Input -- ARRN  "CP"  - to be printed or "DEL" - in delimited format
"RTN","GMRCSTL8",133,0)
 ;SVCN = node in ^TMP("GMRCLIST,$J..STAT = status being worked on..DT1 = 60 days before starting date of current quarter
"RTN","GMRCSTL8",134,0)
 ;Output -- None
"RTN","GMRCSTL8",135,0)
 N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP,FLG,TYPE
"RTN","GMRCSTL8",136,0)
 S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1)
"RTN","GMRCSTL8",137,0)
 S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2)
"RTN","GMRCSTL8",138,0)
 S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3)
"RTN","GMRCSTL8",139,0)
 S GMRCXDT=""
"RTN","GMRCSTL8",140,0)
 F  S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT=""  D
"RTN","GMRCSTL8",141,0)
 .S GMRCPT=0
"RTN","GMRCSTL8",142,0)
 .;Loop for one consult at a time
"RTN","GMRCSTL8",143,0)
 .F  S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT=""  D
"RTN","GMRCSTL8",144,0)
 ..Q:GMRCXDT<(9999999-DT1-.6)  ;
"RTN","GMRCSTL8",145,0)
 ..S FLG=0 D EXCLUDE Q:$G(FLG)=1
"RTN","GMRCSTL8",146,0)
 ..S TYPE="" D REQTYPE
"RTN","GMRCSTL8",147,0)
 ..I TYPE="LOCAL" D
"RTN","GMRCSTL8",148,0)
 ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,5)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,5)+1
"RTN","GMRCSTL8",149,0)
 ...; get unresolved requests for the period
"RTN","GMRCSTL8",150,0)
 ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,6)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,6)+1
"RTN","GMRCSTL8",151,0)
 ..I TYPE="IFCP" D
"RTN","GMRCSTL8",152,0)
 ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,11)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,11)+1
"RTN","GMRCSTL8",153,0)
 ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,12)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,12)+1
"RTN","GMRCSTL8",154,0)
 ..I TYPE="IFCF" D
"RTN","GMRCSTL8",155,0)
 ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,17)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,17)+1
"RTN","GMRCSTL8",156,0)
 ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,18)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,18)+1
"RTN","GMRCSTL8",157,0)
 Q
"RTN","GMRCSTL8",158,0)
REQTYPE  ;If the request is being requested and performed locally, this field will be blank; Placer done elsewhere, Filler done locally
"RTN","GMRCSTL8",159,0)
 I $P(^GMR(123,$G(GMRCPT),0),U,23)="" S TYPE="LOCAL" Q
"RTN","GMRCSTL8",160,0)
 I $P(^GMR(123,$G(GMRCPT),0),U,23)'=""&($P($G(^GMR(123,GMRCPT,12)),U,5)="P") S TYPE="IFCP" Q
"RTN","GMRCSTL8",161,0)
 I $P(^GMR(123,$G(GMRCPT),0),U,23)'=""&($P($G(^GMR(123,GMRCPT,12)),U,5)="F") S TYPE="IFCF" Q
"RTN","GMRCSTL8",162,0)
 Q
"RTN","GMRCSTL8",163,0)
EXCLUDE ;exclude these request types from the count
"RTN","GMRCSTL8",164,0)
 N PROS
"RTN","GMRCSTL8",165,0)
 ; Check for bad "AE" x-ref
"RTN","GMRCSTL8",166,0)
 I '$D(^GMR(123,GMRCPT,0)) D  S FLG=1 Q
"RTN","GMRCSTL8",167,0)
 .K ^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)
"RTN","GMRCSTL8",168,0)
 I $$TESTPAT^VADPT(+$P(^GMR(123,GMRCPT,0),U,2)) S FLG=1 Q  ; exclude test pats
"RTN","GMRCSTL8",169,0)
 D  I $G(PROS) S FLG=1 Q
"RTN","GMRCSTL8",170,0)
 .N SVC S SVC=$P(^GMR(123,GMRCPT,0),U,5)
"RTN","GMRCSTL8",171,0)
 .I +$G(^GMR(123.5,SVC,"INT")) S PROS=1 ; exclude PROS consults
"RTN","GMRCSTL8",172,0)
 I $P($G(^GMR(123,GMRCPT,0)),U,18)'="O" S FLG=1 Q  ; only getting outpat
"RTN","GMRCSTL8",173,0)
 I $G(^GMR(123,GMRCPT,70))["Y" S FLG=1 Q  ; exclude admin requests
"RTN","GMRCSTL8",174,0)
 Q
"RTN","GMRCSTL8",175,0)
CHKRNG ;check if request is complete within 30/60 days of Desired Date or Date of Request
"RTN","GMRCSTL8",176,0)
 N DTOR,DTCMPL S DTOR="",DTCMPL=""
"RTN","GMRCSTL8",177,0)
 Q:'$O(^GMR(123,+$G(GMRCPT),50,0))&('$O(^GMR(123,+$G(GMRCPT),51,0)))
"RTN","GMRCSTL8",178,0)
 I $P(^GMR(123,+$G(GMRCPT),0),U,24)>0 S DTOR=$P(^GMR(123,+$G(GMRCPT),0),U,24) ;check for desired date CPRS GUI v28
"RTN","GMRCSTL8",179,0)
 S:$G(DTOR)="" DTOR=$P(^GMR(123,+$G(GMRCPT),0),U,7)
"RTN","GMRCSTL8",180,0)
 ; if request is completed and has results, was it completed within 30 or 60 days of the Date of Request, field 3 in 123 [0;7]
"RTN","GMRCSTL8",181,0)
 ;order through activity multiple (40) and find the entry for completed 40, [0:2] - value of 10 is complete/update
"RTN","GMRCSTL8",182,0)
 N CHK S CHK=0
"RTN","GMRCSTL8",183,0)
 F  S CHK=$O(^GMR(123,+$G(GMRCPT),40,CHK)) Q:CHK="B"  D
"RTN","GMRCSTL8",184,0)
 .;get the date/time of completion 40, [0;3]
"RTN","GMRCSTL8",185,0)
 .I $D(^GMR(123,+$G(GMRCPT),40,CHK,0)) S:($P(^GMR(123,GMRCPT,40,CHK,0),U,2)=10) DTCMPL=$P(^GMR(123,GMRCPT,40,CHK,0),U,3)
"RTN","GMRCSTL8",186,0)
 I $G(DTCMPL) D
"RTN","GMRCSTL8",187,0)
 .I (STR="30")&(DTCMPL<=$$FMADD^XLFDT(DTOR,30)) D
"RTN","GMRCSTL8",188,0)
 ..S:TYPE="LOCAL" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,3)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,3)+1
"RTN","GMRCSTL8",189,0)
 ..S:TYPE="IFCP" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,9)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,9)+1
"RTN","GMRCSTL8",190,0)
 ..S:TYPE="IFCF" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,15)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,15)+1
"RTN","GMRCSTL8",191,0)
 .I STR'="30"&(DTCMPL<=$$FMADD^XLFDT(DTOR,60))&(DTCMPL>$$FMADD^XLFDT(DTOR,30)) D
"RTN","GMRCSTL8",192,0)
 ..S:TYPE="LOCAL" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,4)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,4)+1
"RTN","GMRCSTL8",193,0)
 ..S:TYPE="IFCP" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,10)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,10)+1
"RTN","GMRCSTL8",194,0)
 ..S:TYPE="IFCF" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,16)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,16)+1
"RTN","GMRCSTL8",195,0)
 Q
"VER")
8.0^22.0
"^DD",123,123,17,0)
EARLIEST DATE^D^^0;24^S %DT="E" D ^%DT S X=Y K:X<1 X
"^DD",123,123,17,3)
Enter earliest date desired for consultation
"^DD",123,123,17,"DT")
3090114
**END**
**END**