ORCSAVE2 ;SLC/MKB-Utilities to update an order ;14-May-2010 11:23;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,1003,1005,157,215,265,243,1010**;Dec 17, 1997;Build 47
;;Per VHA Directive 2004-038, this routine should not be modified.
;Modified - IHS/MSC/PLS - 5/14/2010 - Lines STRT+2, STOP+2, CVTDATE EP
STATUS(IFN,ST) ; -- Update status of order
Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:$P($G(^(3)),U,3)=$G(ST) ;no change
Q:'$G(ST) Q:'$D(^ORD(100.01,+ST,0))
N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP
S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT
S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3
I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12))
I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN
I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent
D SETALL^ORDD100(+IFN)
Q
;
CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate
N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS
Q:'$D(^OR(100,ORIFN,0)) S ORSTS=$P($G(^(3)),U,3)
I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D Q ;Parent unrel'd - ck children
. F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLRELSD
. . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
. . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0
. I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending
S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0
F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLDONE
. I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q
. S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q
. I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q
. I "^2^7^"[(U_CHSTS_U) S COMP=1 Q
. S ALLDONE=0 S:CHSTS=6 ACTIVE=1
I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q
I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active
Q
;
RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service
S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
Q:'$G(ORDER) N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0))
S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0)))
S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)=""
;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)=""
S $P(OR0,U,16,17)=WHEN_U_WHO
S ^OR(100,ORDER,8,ACTION,0)=OR0
I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER)
;Set the "AR" index.
D RS^ORDD100(ORDER,ACTION,ORVP,WHEN)
Q
;
STARTDT(DA) ; -- resolve Start and Stop dates from Responses
N X,Y,%DT,ORDG,ORT,ORLAB
S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3)
S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT=""
S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA)
STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q S:$L(ORT) X=X_"@"_ORT
D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST"
; IHS/MSC/DKM - Modified next line to accommodate alternate date format
;S %DT="TX" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
S %DT="TX",X=$$CVTDATE(X) D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1 S X=$$FMADD^XLFDT(Y,(X-1))
I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X) S:$L(ORT) X=X_"@"_ORT
; IHS/MSC/DKM - Modified next line to accommodate alternate date format
;S %DT="TX" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
S %DT="TX",X=$$CVTDATE(X) D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A
Q
;
NEXT ; -- Resolve next lab collection to FM date/time
N ORTIME,ORDAY,NOW,NEXT,ENT
;is referenced by DBIA #964
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"
D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1")
S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0
S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U)
Q
;
AM ; -- Resolve AM lab collection to FM date/time
N ORTIME,ORDAY,AM,NOW,ENT
;is referenced by DBIA #964
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"
D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
S AM=$O(ORTIME(0)),NOW=$P($H,",",2)
S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1")
S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U)
Q
;
ADMIN(START) ; -- Resolve next/closest administration times to FM date/time
N PAT,SCH,OI,LOC,Y,I
I $G(DA) D ;get data from order DA
. S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC=""
. S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first
. S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE")
I '$G(DA) D ;or look in ORDIALOG() instead
. S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0))
. S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I))
. S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC=""
S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI
;is referenced by DBIA #3167
S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2)
Q
;
SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order
Q:'$G(DA) S:'$G(WHAT) WHAT=1
N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref
S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"")
; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer
S ^OR(100,DA,8,WHAT,0)=X
D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref
Q
;
SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns]
; Expects ORNATR, ORVP, ORNP to be defined
Q:'$G(IFN) Q:'$G(ACT) N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U)
S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3)
K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)
S $P(^OR(100,+IFN,8,ACT,0),U,4)=X
I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN
Q
;
UNVEIL(IFN) ; -- unveil new order
S $P(^OR(100,IFN,3),U,8)=""
Q
;
DELETE(ORDER) ; -- delete order [action]
N DIK,DA,DAD
I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q
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
K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text
Q
;
VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified
Q:'$G(IFN) Q:'$G(DA) Q:"^N^C^R^"'[(U_$G(TYPE)_U)
N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18)
S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN
D:$L($T(VER^EDPFMON)) VER^EDPFMON(IFN)
Q
;
COMP(IFN,WHO,WHEN) ; -- order completed
Q:'$G(IFN) S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12)
D DATES(+IFN,,WHEN),STATUS(+IFN,2)
S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO
D:$L($T(COMP^EDPFMON)) COMP^EDPFMON(IFN)
Q
;
DATES(DA,START,STOP) ; -- Update start/stop dates for order DA
Q:'$G(DA) I $G(START) D
. Q:START=$P(^OR(100,DA,0),U,8)
. D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA)
. S $P(^OR(100,DA,0),U,8)=START
. D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA)
I $G(STOP) D
. ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway
. D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A
Q
;
OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9)
Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,9)
N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0
S CDL=0 F S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0 D
. S I=0 F S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0 D
. . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC
. . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW
. . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)=""
. . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245)
S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
Q
;
VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID
I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q ""
N I,Y S I=0,Y="" S:'$G(INST) INST=1
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
Q Y
;
SC(ORX,ORIFN) ; -- save responses to SC questions
Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) ;invalid order number
N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=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)
S ^OR(100,+ORIFN,5)=OR5
Q
;
CANCEL(ORDER) ; -- cancel order [action]
N ORA,DIE,DA,DR,ORX
S ORDER=$G(ORDER),ORA=+$P(ORDER,";",2) Q:'ORA!('ORDER)
I $D(^OR(100,+ORDER,8,ORA)) D
.S ORX="Unsigned/unreleased order cancelled by provider"
.S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
.S DR="4////5;15////13;1////^S X=ORX" D ^DIE
I ORA=1 D
.K DA S DIE="^OR(100,",DA=+ORDER,DR="5////13" D ^DIE
Q
;
LAPSE(ORDER) ; -- lapse order [action]
N ORA S ORA=+$P(ORDER,";",2)
Q:'$D(^OR(100,+ORDER,0)) Q:'ORA!('ORDER)
I $D(^OR(100,+ORDER,8,ORA)) D
.N DIE,DA,DR
.S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER
.S DR="4////5;15////14" D ^DIE
I ORA=1 D
.N DIE,DA,DR
.S DIE="^OR(100,",DA=+ORDER,DR="5////14"
.D ^DIE,ALPS(DA,ORA)
Q
ALPS(DA,ORACT,TYPE) ;set the lapse index ^OR(100,"ALPS")
N ORVP,X,OR0,ORLOG
S OR0=$G(^OR(100,DA,8,ORACT,0))
S ORLOG=$P(OR0,U),ORVP=$P($G(^OR(100,DA,0)),U,2)
I ORVP,ORLOG S ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$G(TYPE)
S ^OR(100,DA,10)=$$NOW^XLFDT
Q
;
RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue
S IFN=+$G(IFN),VAL=$G(VAL),PRMT=+$O(^ORD(101.41,"AB",PRMT,0))
N ID,DA,DIK S:'$G(INST) INST=1
S ID=$P($G(^ORD(101.41,PRMT,1)),U,3) Q:'$L(ID)
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
I 'DA D:$L(VAL) Q ;add
. N DO,DIC,DLG,X
. S DIC="^OR(100,"_IFN_",4.5,",DA(1)=IFN,DIC(0)="FL"
. S DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID
. S DLG=+$P($G(^OR(100,IFN,0)),U,5)
. S X=+$O(^ORD(101.41,DLG,10,"D",PRMT,0))
. D FILE^DICN S:Y ^OR(100,IFN,4.5,+Y,1)=VAL
I $L(VAL) S ^OR(100,IFN,4.5,DA,1)=VAL Q ;change
S DIK="^OR(100,"_IFN_",4.5,",DA(1)=IFN D ^DIK ;delete
Q
CVTDATE(X) ; Converts space-delimited time to @-delimited
N Y
S Y=$L(X," ")
Q $S(X["@":X,Y<2:X,$P(X," ",Y)?1.N1":"1.N.E:$P(X," ",1,Y-1)_"@"_$P(X," ",Y),1:X)
ORCSAVE2 ;SLC/MKB-Utilities to update an order ;14-May-2010 11:23;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,1003,1005,157,215,265,243,1010**;Dec 17, 1997;Build 47
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Modified - IHS/MSC/PLS - 5/14/2010 - Lines STRT+2, STOP+2, CVTDATE EP
STATUS(IFN,ST) ; -- Update status of order
+1 ;no change
IF '$GET(IFN)
QUIT
IF '$DATA(^OR(100,+IFN,0))
QUIT
IF $PIECE($GET(^(3)),U,3)=$GET(ST)
QUIT
+2 IF '$GET(ST)
QUIT
IF '$DATA(^ORD(100.01,+ST,0))
QUIT
+3 NEW NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP
+4 SET NODE3=$GET(^OR(100,+IFN,3))
SET ORVP=$PIECE($GET(^(0)),U,2)
SET ORNOW=$$NOW^XLFDT
+5 SET $PIECE(NODE3,U)=ORNOW
SET $PIECE(NODE3,U,3)=ST
SET ^OR(100,+IFN,3)=NODE3
+6 IF (ST<3)!(ST=12)!(ST=13)
IF $GET(ORDCNTRL)'="ZC"
DO DATES(+IFN,,+$EXTRACT(ORNOW,1,12))
+7 IF "^1^2^7^12^13^15^"[(U_ST_U)
DO CANCEL^ORCSEND(+IFN)
DO UNOTIF^ORCSIGN
+8 ; ck siblings to update parent
IF $PIECE(NODE3,U,9)
DO CKPARENT($PIECE(NODE3,U,9))
+9 DO SETALL^ORDD100(+IFN)
+10 QUIT
+11 ;
CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate
+1 NEW ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS
+2 IF '$DATA(^OR(100,ORIFN,0))
QUIT
SET ORSTS=$PIECE($GET(^(3)),U,3)
+3 ;Parent unrel'd - ck children
IF (ORSTS=11)!(ORSTS=10)
SET ALLRELSD=1
Begin DoDot:1
+4 FOR CH=0:0
SET CH=$ORDER(^OR(100,ORIFN,2,CH))
IF CH'>0
QUIT
Begin DoDot:2
+5 IF '$DATA(^OR(100,CH))
KILL ^OR(100,ORIFN,2,CH)
QUIT
+6 SET CHSTS=$PIECE($GET(^OR(100,CH,3)),U,3)
IF CHSTS=11
SET ALLRELSD=0
End DoDot:2
IF 'ALLRELSD
QUIT
+7 ; update Parent order to pending
IF ALLRELSD
DO STATUS(ORIFN,5)
End DoDot:1
QUIT
+8 SET ALLDONE=1
SET (DC,COMP,LAPS,ACTIVE)=0
+9 FOR CH=0:0
SET CH=$ORDER(^OR(100,ORIFN,2,CH))
IF CH'>0
QUIT
Begin DoDot:1
+10 IF '$DATA(^OR(100,CH))
KILL ^OR(100,ORIFN,2,CH)
QUIT
+11 SET CHSTS=$PIECE($GET(^OR(100,CH,3)),U,3)
IF CHSTS=14
SET LAPS=1
QUIT
+12 IF "^1^12^13^"[(U_CHSTS_U)
SET DC=1
QUIT
+13 IF "^2^7^"[(U_CHSTS_U)
SET COMP=1
QUIT
+14 SET ALLDONE=0
IF CHSTS=6
SET ACTIVE=1
End DoDot:1
IF 'ALLDONE
QUIT
+15 IF ALLDONE
SET ORSTS=$SELECT(COMP:2,DC:1,LAPS:14,1:"")
IF ORSTS
DO STATUS(ORIFN,ORSTS)
QUIT
+16 ;at least child active
IF ACTIVE
IF ORSTS'=6
DO STATUS(ORIFN,6)
+17 QUIT
+18 ;
RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service
+1 IF '$GET(ACTION)
SET ACTION=1
IF '$GET(WHEN)
SET WHEN=+$EXTRACT($$NOW^XLFDT,1,12)
IF '$GET(WHO)
SET WHO=DUZ
+2 IF '$GET(ORDER)
QUIT
NEW OR0
SET OR0=$GET(^OR(100,ORDER,8,ACTION,0))
+3 IF $LENGTH($GET(NATURE))
SET $PIECE(OR0,U,12)=$SELECT(NATURE:NATURE,1:+$ORDER(^ORD(100.02,"C",NATURE,0)))
+4 IF ($PIECE(OR0,U,15)=10)!($PIECE(OR0,U,15)=11)
SET $PIECE(OR0,U,15)=""
+5 ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)=""
+6 SET $PIECE(OR0,U,16,17)=WHEN_U_WHO
+7 SET ^OR(100,ORDER,8,ACTION,0)=OR0
+8 IF $PIECE(OR0,U,2)="NW"
IF '$PIECE(^OR(100,ORDER,0),U,8)
DO STARTDT(ORDER)
+9 ;Set the "AR" index.
+10 DO RS^ORDD100(ORDER,ACTION,ORVP,WHEN)
+11 QUIT
+12 ;
STARTDT(DA) ; -- resolve Start and Stop dates from Responses
+1 NEW X,Y,%DT,ORDG,ORT,ORLAB
+2 SET ORDG=$PIECE($GET(^ORD(100.98,+$PIECE(^OR(100,DA,0),U,11),0)),U,3)
+3 SET ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U)
SET ORT=""
+4 IF ORDG="E/L T"
SET ORT=$$VALUE(DA,"TIME")
IF ORDG="MEAL"
SET ORT=$$MEALTIME^ORCDFHO(DA)
STRT SET X=$$VALUE(DA,"START")
IF '$LENGTH(X)
DO WS^ORDD100
QUIT
IF $LENGTH(ORT)
SET X=X_"@"_ORT
+1 IF X="AM"
DO AM
IF X="NEXT"
DO NEXT
IF X="NEXTA"
DO ADMIN("NEXT")
IF X="CLOSEST"
DO ADMIN("CLOSEST")
+2 ; IHS/MSC/DKM - Modified next line to accommodate alternate date format
+3 ;S %DT="TX" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
+4 SET %DT="TX"
SET X=$$CVTDATE(X)
DO ^%DT
IF Y'>0
QUIT
IF $EXTRACT($PIECE(Y,".",2),1,2)=24
SET Y=$PIECE(Y,".")_".2359"
+5 SET $PIECE(^OR(100,DA,0),U,8)=Y
DO SS^ORDD100
DO WS^ORDD100
DO OI1^ORDD100A(DA)
STOP IF ORLAB
SET X=$$VALUE(DA,"DAYS")
IF X'>1
QUIT
SET X=$$FMADD^XLFDT(Y,(X-1))
+1 IF 'ORLAB
SET X=$$VALUE(DA,"STOP")
IF '$LENGTH(X)
QUIT
IF $LENGTH(ORT)
SET X=X_"@"_ORT
+2 ; IHS/MSC/DKM - Modified next line to accommodate alternate date format
+3 ;S %DT="TX" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359"
+4 SET %DT="TX"
SET X=$$CVTDATE(X)
DO ^%DT
IF Y'>0
QUIT
IF $EXTRACT($PIECE(Y,".",2),1,2)=24
SET Y=$PIECE(Y,".")_".2359"
+5 SET $PIECE(^OR(100,DA,0),U,9)=Y
DO ES^ORDD100A
+6 QUIT
+7 ;
NEXT ; -- Resolve next lab collection to FM date/time
+1 NEW ORTIME,ORDAY,NOW,NEXT,ENT
+2 ;is referenced by DBIA #964
+3 SET ENT=$SELECT($PIECE($GET(^SC(+$GET(ORL),0)),U,4):+$PIECE(^(0),U,4),1:+$GET(DUZ(2)))_";DIC(4,"
IF ENT'>0
SET ENT="ALL"
+4 DO GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
+5 SET NOW=$PIECE($HOROLOG,",",2)
SET ORDAY=$SELECT($ORDER(ORTIME(NOW)):"T",1:"T+1")
+6 SET ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY)
IF ORDAY["+"
SET NOW=0
+7 SET NEXT=$ORDER(ORTIME(NOW))
SET X=ORDAY_"@"_$PIECE($GET(ORTIME(+NEXT)),U)
+8 QUIT
+9 ;
AM ; -- Resolve AM lab collection to FM date/time
+1 NEW ORTIME,ORDAY,AM,NOW,ENT
+2 ;is referenced by DBIA #964
+3 SET ENT=$SELECT($PIECE($GET(^SC(+$GET(ORL),0)),U,4):+$PIECE(^(0),U,4),1:+$GET(DUZ(2)))_";DIC(4,"
IF ENT'>0
SET ENT="ALL"
+4 DO GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N")
+5 SET AM=$ORDER(ORTIME(0))
SET NOW=$PIECE($HOROLOG,",",2)
+6 SET ORDAY=$SELECT(AM=$ORDER(ORTIME(NOW)):"T",1:"T+1")
+7 SET X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$PIECE($GET(ORTIME(+AM)),U)
+8 QUIT
+9 ;
ADMIN(START) ; -- Resolve next/closest administration times to FM date/time
+1 NEW PAT,SCH,OI,LOC,Y,I
+2 ;get data from order DA
IF $GET(DA)
Begin DoDot:1
+3 SET PAT=+$PIECE($GET(^OR(100,DA,0)),U,2)
SET LOC=""
+4 ;first
SET I=+$ORDER(^OR(100,DA,4.5,"ID","INSTR",0))
SET I=+$PIECE($GET(^OR(100,DA,4.5,I,0)),U,3)
+5 SET SCH=$$VALUE(DA,"SCHEDULE",I)
SET OI=$$VALUE(DA,"ORDERABLE")
End DoDot:1
+6 ;or look in ORDIALOG() instead
IF '$GET(DA)
Begin DoDot:1
+7 SET I=+$ORDER(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0))
+8 SET PAT=$GET(ORVP)
SET SCH=$GET(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I))
+9 SET OI=$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
SET LOC=""
End DoDot:1
+10 ;PSOI
SET OI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
+11 ;is referenced by DBIA #3167
+12 SET Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC)
SET X=$PIECE(Y,U,2)
+13 QUIT
+14 ;
SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order
+1 IF '$GET(DA)
QUIT
IF '$GET(WHAT)
SET WHAT=1
+2 ; kill AS xref
NEW X
SET X=$GET(^OR(100,DA,8,WHAT,0))
DO S2^ORDD100(DA,WHAT)
+3 SET $PIECE(X,U,4,7)=$GET(HOW)_U_$GET(WHO)_U_$EXTRACT($GET(WHEN),1,12)_U_$SELECT(HOW=0:DUZ,1:"")
+4 ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer
+5 SET ^OR(100,DA,8,WHAT,0)=X
+6 ; reset AS xref
IF $GET(HOW)=2
DO S1^ORDD100(DA,WHAT)
+7 QUIT
+8 ;
SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns]
+1 ; Expects ORNATR, ORVP, ORNP to be defined
+2 IF '$GET(IFN)
QUIT
IF '$GET(ACT)
QUIT
NEW X,OR0
SET OR0=+$PIECE($GET(^OR(100,+IFN,8,ACT,0)),U)
+3 SET X=$SELECT($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3)
+4 KILL ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)
+5 SET $PIECE(^OR(100,+IFN,8,ACT,0),U,4)=X
+6 IF X=2
SET ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)=""
DO NOTIF^ORCSIGN
+7 QUIT
+8 ;
UNVEIL(IFN) ; -- unveil new order
+1 SET $PIECE(^OR(100,IFN,3),U,8)=""
+2 QUIT
+3 ;
DELETE(ORDER) ; -- delete order [action]
+1 NEW DIK,DA,DAD
+2 IF $PIECE(ORDER,";",2)>1
SET DA=+$PIECE(ORDER,";",2)
SET DA(1)=+ORDER
SET DIK="^OR(100,"_DA(1)_",8,"
IF DA
DO ^DIK
QUIT
+3 ; remove link to child from parent
SET DAD=+$PIECE($GET(^OR(100,+ORDER,3)),U,9)
IF DAD
SET DIK="^OR(100,"_DAD_",2,"
SET DA(1)=DAD
SET DA=+ORDER
DO ^DIK
+4 ;remove order, text
KILL DA
SET DA=+ORDER
SET DIK="^OR(100,"
DO ^DIK
+5 QUIT
+6 ;
VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified
+1 IF '$GET(IFN)
QUIT
IF '$GET(DA)
QUIT
IF "^N^C^R^"'[(U_$GET(TYPE)_U)
QUIT
+2 NEW FLD
SET FLD=$SELECT(TYPE="N":8,TYPE="C":10,1:18)
+3 IF '$GET(WHO)
SET WHO=DUZ
IF '$GET(WHEN)
SET WHEN=+$EXTRACT($$NOW^XLFDT,1,12)
+4 SET $PIECE(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN
+5 IF $LENGTH($TEXT(VER^EDPFMON))
DO VER^EDPFMON(IFN)
+6 QUIT
+7 ;
COMP(IFN,WHO,WHEN) ; -- order completed
+1 IF '$GET(IFN)
QUIT
IF '$GET(WHO)
SET WHO=DUZ
IF '$GET(WHEN)
SET WHEN=+$EXTRACT($$NOW^XLFDT,1,12)
+2 DO DATES(+IFN,,WHEN)
DO STATUS(+IFN,2)
+3 SET $PIECE(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO
+4 IF $LENGTH($TEXT(COMP^EDPFMON))
DO COMP^EDPFMON(IFN)
+5 QUIT
+6 ;
DATES(DA,START,STOP) ; -- Update start/stop dates for order DA
+1 IF '$GET(DA)
QUIT
IF $GET(START)
Begin DoDot:1
+2 IF START=$PIECE(^OR(100,DA,0),U,8)
QUIT
+3 DO SK^ORDD100
DO WK^ORDD100
DO OI2^ORDD100A(DA)
+4 SET $PIECE(^OR(100,DA,0),U,8)=START
+5 DO SS^ORDD100
DO WS^ORDD100
DO OI1^ORDD100A(DA)
End DoDot:1
+6 IF $GET(STOP)
Begin DoDot:1
+7 ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway
+8 DO EK^ORDD100A
SET $PIECE(^OR(100,DA,0),U,9)=STOP
DO ES^ORDD100A
End DoDot:1
+9 QUIT
+10 ;
OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9)
+1 IF '$GET(ORIFN)
QUIT
IF '$DATA(^OR(100,+ORIFN,0))
QUIT
KILL ^OR(100,+ORIFN,9)
+2 NEW NOW,CNT,CDL,I,OC,OVERIDE
SET NOW=+$EXTRACT($$NOW^XLFDT,1,12)
SET CNT=0
+3 SET CDL=0
FOR
SET CDL=$ORDER(ORCHECK(+ORIFN,CDL))
IF CDL'>0
QUIT
Begin DoDot:1
+4 SET I=0
FOR
SET I=$ORDER(ORCHECK(+ORIFN,CDL,I))
IF I'>0
QUIT
Begin DoDot:2
+5 SET OC=ORCHECK(+ORIFN,CDL,I)
IF 'OC
QUIT
+6 SET OVERIDE=$SELECT($GET(MODE)="NOTIF":$GET(ORCHECK("OK"))_U,CDL=1:$GET(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW
+7 SET CNT=CNT+1
SET ^OR(100,+ORIFN,9,"B",+OC,CNT)=""
+8 SET ^OR(100,+ORIFN,9,CNT,0)=$PIECE(OC,U,1,2)_U_U_OVERIDE
SET ^(1)=$EXTRACT($PIECE(OC,U,3),1,245)
End DoDot:2
End DoDot:1
+9 IF CNT
SET ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
+10 QUIT
+11 ;
VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID
+1 IF '$GET(IFN)!('$DATA(^OR(100,+$GET(IFN),0)))!($GET(ID)="")
QUIT ""
+2 NEW I,Y
SET I=0
SET Y=""
IF '$GET(INST)
SET INST=1
+3 FOR
SET I=$ORDER(^OR(100,IFN,4.5,"ID",ID,I))
IF I'>0
QUIT
IF $PIECE($GET(^OR(100,IFN,4.5,+I,0)),U,3)=INST
SET Y=$GET(^(1))
QUIT
+4 QUIT Y
+5 ;
SC(ORX,ORIFN) ; -- save responses to SC questions
+1 ;invalid order number
IF '$GET(ORIFN)
QUIT
IF '$DATA(^OR(100,+ORIFN,0))
QUIT
+2 NEW OR5,I,P
SET OR5=$GET(^OR(100,+ORIFN,5))
SET P=0
+3 FOR I="SC","MST","AO","IR","EC","HNC","CV","SHD"
SET P=P+1
IF $DATA(ORX(I))
SET $PIECE(OR5,U,P)=ORX(I)
+4 SET ^OR(100,+ORIFN,5)=OR5
+5 QUIT
+6 ;
CANCEL(ORDER) ; -- cancel order [action]
+1 NEW ORA,DIE,DA,DR,ORX
+2 SET ORDER=$GET(ORDER)
SET ORA=+$PIECE(ORDER,";",2)
IF 'ORA!('ORDER)
QUIT
+3 IF $DATA(^OR(100,+ORDER,8,ORA))
Begin DoDot:1
+4 SET ORX="Unsigned/unreleased order cancelled by provider"
+5 SET DIE="^OR(100,"_+ORDER_",8,"
SET DA=ORA
SET DA(1)=+ORDER
+6 SET DR="4////5;15////13;1////^S X=ORX"
DO ^DIE
End DoDot:1
+7 IF ORA=1
Begin DoDot:1
+8 KILL DA
SET DIE="^OR(100,"
SET DA=+ORDER
SET DR="5////13"
DO ^DIE
End DoDot:1
+9 QUIT
+10 ;
LAPSE(ORDER) ; -- lapse order [action]
+1 NEW ORA
SET ORA=+$PIECE(ORDER,";",2)
+2 IF '$DATA(^OR(100,+ORDER,0))
QUIT
IF 'ORA!('ORDER)
QUIT
+3 IF $DATA(^OR(100,+ORDER,8,ORA))
Begin DoDot:1
+4 NEW DIE,DA,DR
+5 SET DIE="^OR(100,"_+ORDER_",8,"
SET DA=ORA
SET DA(1)=+ORDER
+6 SET DR="4////5;15////14"
DO ^DIE
End DoDot:1
+7 IF ORA=1
Begin DoDot:1
+8 NEW DIE,DA,DR
+9 SET DIE="^OR(100,"
SET DA=+ORDER
SET DR="5////14"
+10 DO ^DIE
DO ALPS(DA,ORA)
End DoDot:1
+11 QUIT
ALPS(DA,ORACT,TYPE) ;set the lapse index ^OR(100,"ALPS")
+1 NEW ORVP,X,OR0,ORLOG
+2 SET OR0=$GET(^OR(100,DA,8,ORACT,0))
+3 SET ORLOG=$PIECE(OR0,U)
SET ORVP=$PIECE($GET(^OR(100,DA,0)),U,2)
+4 IF ORVP
IF ORLOG
SET ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$GET(TYPE)
+5 SET ^OR(100,DA,10)=$$NOW^XLFDT
+6 QUIT
+7 ;
RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue
+1 SET IFN=+$GET(IFN)
SET VAL=$GET(VAL)
SET PRMT=+$ORDER(^ORD(101.41,"AB",PRMT,0))
+2 NEW ID,DA,DIK
IF '$GET(INST)
SET INST=1
+3 SET ID=$PIECE($GET(^ORD(101.41,PRMT,1)),U,3)
IF '$LENGTH(ID)
QUIT
+4 SET DA=0
FOR
SET DA=$ORDER(^OR(100,IFN,4.5,"ID",ID,DA))
IF DA<1
QUIT
IF $PIECE($GET(^OR(100,IFN,4.5,DA,0)),U,3)=INST
QUIT
+5 ;add
IF 'DA
IF $LENGTH(VAL)
Begin DoDot:1
+6 NEW DO,DIC,DLG,X
+7 SET DIC="^OR(100,"_IFN_",4.5,"
SET DA(1)=IFN
SET DIC(0)="FL"
+8 SET DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID
+9 SET DLG=+$PIECE($GET(^OR(100,IFN,0)),U,5)
+10 SET X=+$ORDER(^ORD(101.41,DLG,10,"D",PRMT,0))
+11 DO FILE^DICN
IF Y
SET ^OR(100,IFN,4.5,+Y,1)=VAL
End DoDot:1
QUIT
+12 ;change
IF $LENGTH(VAL)
SET ^OR(100,IFN,4.5,DA,1)=VAL
QUIT
+13 ;delete
SET DIK="^OR(100,"_IFN_",4.5,"
SET DA(1)=IFN
DO ^DIK
+14 QUIT
CVTDATE(X) ; Converts space-delimited time to @-delimited
+1 NEW Y
+2 SET Y=$LENGTH(X," ")
+3 QUIT $SELECT(X["@":X,Y<2:X,$PIECE(X," ",Y)?1.N1":"1.N.E:$PIECE(X," ",1,Y-1)_"@"_$PIECE(X," ",Y),1:X)
