ORCSEND1 ;SLC/MKB-Release cont ;24-Apr-2014 12:55;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243,282,1010,1012**;Dec 17, 1997;Build 43
;
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Reference to PSJEEU supported by IA #486
;Reference to PSJORPOE supported by IA #3167
;Modified - IHS/MSC/MGH - 01/11/2012 - Added support for clinical indicator on child orders
; IHS/MSC/PLS - 07/30/2013 - Added SNOMED Concept ID
PKGSTUFF(PKG) ; Package code
S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG)
D:$L($T(@PKG)) @PKG
Q
LR ; Spawn child orders if continuous schedule
N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS
N ORIND,ORIND2,SNMDCID
S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10)
D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D Q
. N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8)
. D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule
S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11)
D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1
K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1)
S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE")
S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN")
S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY")
S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE")
S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME")
;IHS/MSC/MGH add clinical indication to the check and the loop
S ORIND=$$PTR^ORCD("OR GTX CLININD")
S ORIND2=$$PTR("OR GTX CLININD2")
S SNMDCID=$$PTR^ORCD("OR GTX SNMDCNPTID")
LR1 N ORLASTC S ORS1=0 F S ORS1=$O(ORX(ORS1)) Q:ORS1'>0 D
. ;IHS/MSC/MGH add indication to the loop
. F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORIND,ORIND2,SNMDCID S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance
. S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1))
. S ORS2=0 F S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0 D
.. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
.. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC")
.. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC")
.. D CHILD^ORCSEND3()
.. S ORLASTC=$P(^OR(100,ORIFN,0),"^",8)
. D DATES^ORCSAVE2(ORPARENT,,ORLASTC) S $P(^OR(100,ORPARENT,3),"^",8)=1
S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3)
I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders"
D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE))
Q
SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule
N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR
S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q
S ORY=1,ORY(PSJSD)="" ;1st occurrance
S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I Q:'$L($G(PKG))
S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X)
S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX))
I $G(PSJTS)'="C",$G(PSJTS)'="D" Q ;not continuous or day-of-week
S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I
S ORDUR=$G(^OR(100,+IFN,4.5,+I,1))
S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1)
I 'ORDUR S X=+$E(ORDUR,2,9) D
. I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times
. E D ;no freq in minutes --> day of week
.. N DAYS,LOCMX,SCHMX
.. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
.. K ^TMP($J,"ORCSEND1 SCHEDULE")
.. D ZERO^PSS51P1(PSJY,,,,"ORCSEND1 SCHEDULE")
.. S SCHMX=+$G(^TMP($J,"ORCSEND1 SCHEDULE",PSJY,2.5))
.. K ^TMP($J,"ORCSEND1 SCHEDULE")
.. ;S SCHMX=$P(^PS(51.1,PSJY,0),U,7)
.. S DAYS=$S('SCHMX:LOCMX,LOCMX<SCHMX:LOCMX,1:SCHMX)
.. S PSJFD=$$FMADD^XLFDT(PSJSD,DAYS,,-1)
D ENSPU^PSJEEU K ORY
I ORDUR M ORY=PSJC Q
S ORY=$S(PSJC<$E(ORDUR,2,9):PSJC,1:$E(ORDUR,2,9))
N NXT
S NXT=0 F I=1:1:ORY S NXT=$O(PSJC(NXT)) Q:'NXT S ORY(NXT)=PSJC(NXT)
Q
GETORDER(IFN) ; Set ORX(Inst,Ptr)=Value
N I,X,Y,PTR,INST,TYPE
S I=0 F S I=$O(^OR(100,IFN,4.5,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)) D
. S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U)
. I TYPE'="W" S ORX(INST,PTR)=Y Q
. S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)"
Q
PTR(X) ; Returns ptr of prompt X in Order Dialog file
Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
PS ; spawn child orders if multiple doses
PSJ ; (Inpt only)
PSS ;
N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS
N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM
N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I,ORADMIN
S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3))
Q:$P(OR0,U,12)'="I" S ORCAT="I",ORNP=+$P(OR0,U,4)
S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7)
S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14)
D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT)
S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE")
S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION")
S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG"))
S ORADMIN=$$PTR("ADMIN TIMES")
D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1
S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG")
S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG")
S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME")
I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D
. S ORENEW=+$P(OR3,U,5),I=0
. I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0))
. F S I=$O(^OR(100,ORENEW,2,I)) Q:I<1 S ORENEW(I)=""
PS1 F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D
. N PTR S PTR=$$PTR(ORP) Q:PTR'>0 Q:'$D(ORX(1,PTR))
. S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR)
S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D
. F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP)
. S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6)
. S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT
. D SIG,CHILD^ORCSEND3(ORSTART)
F D S ORI=$O(ORX(ORI)) Q:ORI'>0
. F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID,ORADMIN S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)
. K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID))
. S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6)
. S ORSTART=$G(ORSTRT(ORI))
. D SIG,CHILD^ORCSEND3(ORSTART)
S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3)
I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders"
D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J)
S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time?
Q:(STS=1)!(STS=13)!(STS=11) ;unsuccessful
PS2 ; ck if parent is unsigned or edit
I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES
Q:$P(OR3,U,11)'=1 S ORIG=$P(OR3,U,5) Q:ORIG'>0
S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC")
D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D
. N NATR S NATR=+$O(^ORD(100.02,"C","C",0))
. S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW
. D CANCEL^ORCSEND(ORIG) ;ck for unrel actions
Q
DOSES(IFN) ; count number of doses in order
N I,CNT S CNT=0
S I=0 F S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0 I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1
S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1
Q CNT
FRSTDOSE() ; Return instance of first dose
N I,Y S I=0,Y=1
F S I=$O(ORX(I)) Q:I'>0 I $D(ORX(I,ORDOSE)) S Y=I Q
Q Y
SIG ; Build text of instructions
N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1)
S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1))
S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1
S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2
S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX
S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1))
S ORDIALOG(ORDOSE,"FORMAT")="@"
K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1)
I ORDRUG,'ID D ;set strength or drug name
. N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8)
. I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q
. S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U)
. S:ITM'[STR ORDIALOG(ORSTR,1)=STR
Q
STRT ; Build ORSTRT(inst)=date.time array of start times by dose
N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT
S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM")))
S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0
S ORWD=+$G(^SC(+$G(ORL),42)) ;ward
S ORI=0 F S ORI=$O(ORX(ORI)) Q:ORI<1 D
. S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT
. S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4)
. S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET
. ; update OFFSET for next THEN dose
. D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D
.. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration
.. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I))
.. K ORD
; find beginning date.time for parent
S ORI=0,X=9999999 F S ORI=$O(ORSTRT(ORI)) Q:ORI<1 I ORSTRT(ORI)<X S X=ORSTRT(ORI)
S ORSTRT("BEG")=X
Q
DUR(I) ; Accumulate duration in ORD("Xt") for offsetting next THEN dose
N X,Y S X=$$FMDUR^ORCDPS3($G(ORX(I,ORDUR)))
I X["S",+X>$G(ORD("XS")) S ORD("XS")=+X
I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X
I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X
S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0)
I Y,Y>$G(ORD("XD")) S ORD("XD")=Y
Q
VBEC ; Spawn VBECS children
D:$L($T(EN^ORCSEND2)) EN^ORCSEND2
Q
ORCSEND1 ;SLC/MKB-Release cont ;24-Apr-2014 12:55;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243,282,1010,1012**;Dec 17, 1997;Build 43
+2 ;
+3 ;Per VHA Directive 2004-038, this routine should not be modified.
+4 ;
+5 ;Reference to PSJEEU supported by IA #486
+6 ;Reference to PSJORPOE supported by IA #3167
+7 ;Modified - IHS/MSC/MGH - 01/11/2012 - Added support for clinical indicator on child orders
+8 ; IHS/MSC/PLS - 07/30/2013 - Added SNOMED Concept ID
PKGSTUFF(PKG) ; Package code
+1 SET PKG=$$GET1^DIQ(9.4,+PKG_",",1)
IF '$LENGTH(PKG)
QUIT
+2 IF $LENGTH($TEXT(@PKG))
DO @PKG
+3 QUIT
LR ; Spawn child orders if continuous schedule
+1 NEW ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS
+2 NEW ORIND,ORIND2,SNMDCID
+3 SET ORPARENT=+ORIFN
SET OR0=$GET(^OR(100,ORIFN,0))
SET ORL=$PIECE(OR0,U,10)
+4 DO SCHEDULE(ORIFN,"LR",.ORSTRT)
IF ORSTRT'>1
Begin DoDot:1
+5 NEW START
SET START=$ORDER(ORSTRT(0))
IF START=$PIECE($GET(^OR(100,+ORIFN,0)),U,8)
QUIT
+6 ;update start date from schedule
DO DATES^ORCSAVE2(+ORIFN,START)
End DoDot:1
QUIT
+7 SET ORNP=+$PIECE(OR0,U,4)
SET ORDIALOG=+$PIECE(OR0,U,5)
SET ORDUZ=+$PIECE(OR0,U,6)
SET ORLOG=$PIECE(OR0,U,7)
SET ORDG=+$PIECE(OR0,U,11)
+8 DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER(ORIFN)
DO GETIMES^ORCDLR1
+9 KILL ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1)
+10 SET ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
+11 SET ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE")
+12 SET ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN")
+13 SET ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY")
+14 SET ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
+15 SET ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE")
+16 SET ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME")
+17 ;IHS/MSC/MGH add clinical indication to the check and the loop
+18 SET ORIND=$$PTR^ORCD("OR GTX CLININD")
+19 SET ORIND2=$$PTR("OR GTX CLININD2")
+20 SET SNMDCID=$$PTR^ORCD("OR GTX SNMDCNPTID")
LR1 NEW ORLASTC
SET ORS1=0
FOR
SET ORS1=$ORDER(ORX(ORS1))
IF ORS1'>0
QUIT
Begin DoDot:1
+1 ;IHS/MSC/MGH add indication to the loop
+2 ;set values to next instance
FOR P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORIND,ORIND2,SNMDCID
SET ORDIALOG(P,1)=$GET(ORX(ORS1,P))
+3 SET ORCOLLCT=$GET(ORDIALOG(ORPTYPE,1))
+4 SET ORS2=0
FOR
SET ORS2=$ORDER(ORSTRT(ORS2))
IF ORS2'>0
QUIT
Begin DoDot:2
+5 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
SET ORDIALOG(ORPCOLL,1)=ORS2
+6 IF ORCOLLCT="LC"
SET ORDIALOG(ORPTYPE,1)=$SELECT($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC")
+7 IF ORCOLLCT="I"
SET ORDIALOG(ORPTYPE,1)=$SELECT($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC")
+8 DO CHILD^ORCSEND3()
+9 SET ORLASTC=$PIECE(^OR(100,ORIFN,0),"^",8)
End DoDot:2
+10 DO DATES^ORCSAVE2(ORPARENT,,ORLASTC)
SET $PIECE(^OR(100,ORPARENT,3),"^",8)=1
End DoDot:1
+11 IF $GET(ORCHLD)
SET ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
+12 SET ORIFN=ORPARENT
SET ORQUIT=1
SET STS=$PIECE(^OR(100,ORIFN,3),U,3)
+13 IF (STS=1)!(STS=13)!(STS=11)
SET ORERR="1^Unable to release orders"
+14 DO RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$GET(NATURE))
+15 QUIT
SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule
+1 NEW I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR
+2 SET PSJSD=$SELECT(+$GET(STRT):STRT,1:$PIECE($GET(^OR(100,+IFN,0)),U,8))
IF 'PSJSD
SET ORY=-1
QUIT
+3 ;1st occurrance
SET ORY=1
SET ORY(PSJSD)=""
+4 SET I=$ORDER(^OR(100,+IFN,4.5,"ID","SCHEDULE",0))
IF 'I
QUIT
IF '$LENGTH($GET(PKG))
QUIT
+5 SET X=$GET(^OR(100,+IFN,4.5,I,1))
SET PSJX=$SELECT(X:$$GET1^DIQ(51.1,+X_",",.01),1:X)
+6 SET PSJW=+$GET(ORL)
SET PSJNE=""
SET PSJPP=PKG
DO ENSV^PSJEEU
IF '$LENGTH($GET(PSJX))
QUIT
+7 ;not continuous or day-of-week
IF $GET(PSJTS)'="C"
IF $GET(PSJTS)'="D"
QUIT
+8 SET PSJSCH=PSJX
SET I=$ORDER(^OR(100,+IFN,4.5,"ID","DAYS",0))
IF 'I
QUIT
+9 SET ORDUR=$GET(^OR(100,+IFN,4.5,+I,1))
+10 IF ORDUR
SET PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1)
+11 IF 'ORDUR
SET X=+$EXTRACT(ORDUR,2,9)
Begin DoDot:1
+12 ;X_#times
IF PSJM
SET PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1)
+13 ;no freq in minutes --> day of week
IF '$TEST
Begin DoDot:2
+14 NEW DAYS,LOCMX,SCHMX
+15 SET LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
+16 KILL ^TMP($JOB,"ORCSEND1 SCHEDULE")
+17 DO ZERO^PSS51P1(PSJY,,,,"ORCSEND1 SCHEDULE")
+18 SET SCHMX=+$GET(^TMP($JOB,"ORCSEND1 SCHEDULE",PSJY,2.5))
+19 KILL ^TMP($JOB,"ORCSEND1 SCHEDULE")
+20 ;S SCHMX=$P(^PS(51.1,PSJY,0),U,7)
+21 SET DAYS=$SELECT('SCHMX:LOCMX,LOCMX<SCHMX:LOCMX,1:SCHMX)
+22 SET PSJFD=$$FMADD^XLFDT(PSJSD,DAYS,,-1)
End DoDot:2
End DoDot:1
+23 DO ENSPU^PSJEEU
KILL ORY
+24 IF ORDUR
MERGE ORY=PSJC
QUIT
+25 SET ORY=$SELECT(PSJC<$EXTRACT(ORDUR,2,9):PSJC,1:$EXTRACT(ORDUR,2,9))
+26 NEW NXT
+27 SET NXT=0
FOR I=1:1:ORY
SET NXT=$ORDER(PSJC(NXT))
IF 'NXT
QUIT
SET ORY(NXT)=PSJC(NXT)
+28 QUIT
GETORDER(IFN) ; Set ORX(Inst,Ptr)=Value
+1 NEW I,X,Y,PTR,INST,TYPE
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,IFN,4.5,I))
IF I'>0
QUIT
SET X=$GET(^(I,0))
SET Y=$GET(^(1))
Begin DoDot:1
+3 SET PTR=+$PIECE(X,U,2)
SET INST=+$PIECE(X,U,3)
SET TYPE=$PIECE($GET(^ORD(101.41,PTR,1)),U)
+4 IF TYPE'="W"
SET ORX(INST,PTR)=Y
QUIT
+5 SET ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)"
End DoDot:1
+6 QUIT
PTR(X) ; Returns ptr of prompt X in Order Dialog file
+1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_X,1,63),0))
PS ; spawn child orders if multiple doses
PSJ ; (Inpt only)
PSS ;
+1 NEW ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS
+2 NEW ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM
+3 NEW ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I,ORADMIN
+4 SET ORPARENT=+ORIFN
SET OR0=$GET(^OR(100,ORPARENT,0))
SET OR3=$GET(^(3))
+5 IF $PIECE(OR0,U,12)'="I"
QUIT
SET ORCAT="I"
SET ORNP=+$PIECE(OR0,U,4)
+6 SET ORDIALOG=+$PIECE(OR0,U,5)
SET ORDUZ=+$PIECE(OR0,U,6)
SET ORLOG=$PIECE(OR0,U,7)
+7 SET ORL=$PIECE(OR0,U,10)
SET ORDG=+$PIECE(OR0,U,11)
SET ORPKG=+$PIECE(OR0,U,14)
+8 DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER(ORPARENT)
+9 SET ORDOSE=$$PTR("INSTRUCTIONS")
SET ORT=$$PTR("ROUTE")
+10 SET ORSCH=$$PTR("SCHEDULE")
SET ORDUR=$$PTR("DURATION")
+11 SET ORCONJ=$$PTR("AND/THEN")
DO STRT
SET ORSTART=$GET(ORSTRT("BEG"))
+12 SET ORADMIN=$$PTR("ADMIN TIMES")
+13 DO DATES^ORCSAVE2(ORPARENT,ORSTART)
IF $$DOSES(ORPARENT)'>1
QUIT
+14 SET ORFRST=$$PTR("NOW")
SET ORSIG=$$PTR("SIG")
+15 SET ORID=$$PTR("DOSE")
SET ORDD=$$PTR("DISPENSE DRUG")
+16 SET ORSTR=$$PTR("STRENGTH")
SET ORDGNM=$$PTR("DRUG NAME")
+17 IF $PIECE(OR3,U,11)=2
IF $ORDER(^OR(100,+$PIECE(OR3,U,5),2,0))
Begin DoDot:1
+18 SET ORENEW=+$PIECE(OR3,U,5)
SET I=0
+19 IF $$VALUE^ORX8(ORENEW,"NOW")
SET I=$ORDER(^OR(100,ORENEW,2,0))
+20 FOR
SET I=$ORDER(^OR(100,ORENEW,2,I))
IF I<1
QUIT
SET ORENEW(I)=""
End DoDot:1
PS1 FOR ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1"
Begin DoDot:1
+1 NEW PTR
SET PTR=$$PTR(ORP)
IF PTR'>0
QUIT
IF '$DATA(ORX(1,PTR))
QUIT
+2 SET ORDIALOG(PTR,1)=ORX(1,PTR)
IF $EXTRACT(ORP)="O"
SET OROI=ORX(1,PTR)
End DoDot:1
+3 SET ORI=$$FRSTDOSE
IF $GET(ORX(1,ORFRST))
Begin DoDot:1
+4 FOR ORP=ORDOSE,ORT,ORID
IF $DATA(ORX(ORI,ORP))
SET ORDIALOG(ORP,1)=ORX(ORI,ORP)
+5 SET ID=$GET(ORX(ORI,ORID))
IF $PIECE(ID,"&",6)
SET ORDIALOG(ORDD,1)=$PIECE(ID,"&",6)
+6 SET ORDIALOG(ORSCH,1)="NOW"
SET ORSTART=$$NOW^XLFDT
+7 DO SIG
DO CHILD^ORCSEND3(ORSTART)
End DoDot:1
+8 FOR
Begin DoDot:1
+9 FOR ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID,ORADMIN
IF $DATA(ORX(ORI,ORP))
SET ORDIALOG(ORP,1)=ORX(ORI,ORP)
IF '$DATA(ORX(ORI,ORP))
KILL ORDIALOG(ORP,1)
+10 KILL ORDIALOG(ORDD,1)
SET ID=$GET(ORX(ORI,ORID))
+11 IF $PIECE(ID,"&",6)
SET ORDIALOG(ORDD,1)=$PIECE(ID,"&",6)
+12 SET ORSTART=$GET(ORSTRT(ORI))
+13 DO SIG
DO CHILD^ORCSEND3(ORSTART)
End DoDot:1
SET ORI=$ORDER(ORX(ORI))
IF ORI'>0
QUIT
+14 IF $GET(ORCHLD)
SET ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
+15 SET ORIFN=ORPARENT
SET ORQUIT=1
SET OR3=$GET(^OR(100,ORIFN,3))
SET STS=$PIECE(OR3,U,3)
+16 IF (STS=1)!(STS=13)!(STS=11)
SET ORERR="1^Unable to release orders"
+17 DO RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$GET(NATURE))
KILL ^TMP("ORWORD",$JOB)
+18 ;veil parent order - set stop date/time?
SET $PIECE(^OR(100,ORIFN,3),U,8)=1
+19 ;unsuccessful
IF (STS=1)!(STS=13)!(STS=11)
QUIT
PS2 ; ck if parent is unsigned or edit
+1 ;clear ES
IF $PIECE($GET(^OR(100,ORIFN,8,1,0)),U,4)=2
SET $PIECE(^(0),U,4)=""
KILL ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1)
+2 IF $PIECE(OR3,U,11)'=1
QUIT
SET ORIG=$PIECE(OR3,U,5)
IF ORIG'>0
QUIT
+3 SET CODE=$SELECT($PIECE($GET(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC")
+4 DO MSG^ORMBLD(ORIG,CODE)
IF "^1^13^"[(U_$PIECE($GET(^OR(100,ORIG,3)),U,3)_U)
Begin DoDot:1
+5 NEW NATR
SET NATR=+$ORDER(^ORD(100.02,"C","C",0))
+6 SET $PIECE(^OR(100,ORIG,3),U,3)=12
SET $PIECE(^(3),U,7)=0
SET ^(6)=NATR_U_DUZ_U_ORNOW
+7 ;ck for unrel actions
DO CANCEL^ORCSEND(ORIG)
End DoDot:1
+8 QUIT
DOSES(IFN) ; count number of doses in order
+1 NEW I,CNT
SET CNT=0
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,+$GET(IFN),4.5,"ID","INSTR",I))
IF I'>0
QUIT
IF $LENGTH($GET(^OR(100,+$GET(IFN),4.5,I,1)))
SET CNT=CNT+1
+3 SET I=+$ORDER(^OR(100,+$GET(IFN),4.5,"ID","NOW",0))
IF I
IF $GET(^OR(100,+$GET(IFN),4.5,I,1))
SET CNT=CNT+1
+4 QUIT CNT
FRSTDOSE() ; Return instance of first dose
+1 NEW I,Y
SET I=0
SET Y=1
+2 FOR
SET I=$ORDER(ORX(I))
IF I'>0
QUIT
IF $DATA(ORX(I,ORDOSE))
SET Y=I
QUIT
+3 QUIT Y
SIG ; Build text of instructions
+1 NEW ORDRUG,ID,DOSE,ORI,ORX
KILL ^TMP("ORWORD",$JOB,ORSIG,1)
+2 SET ORDRUG=$GET(ORDIALOG(ORDD,1))
SET ID=$GET(ORDIALOG(ORID,1))
+3 SET DOSE=$GET(ORDIALOG(ORDOSE,1))
SET ORI=1
+4 SET ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2
+5 SET ^TMP("ORWORD",$JOB,ORSIG,1,0)="^^1^1^"_DT_U
SET ^(1,0)=ORX
+6 SET ORDIALOG(ORSIG,1)=$NAME(^TMP("ORWORD",$JOB,ORSIG,1))
+7 SET ORDIALOG(ORDOSE,"FORMAT")="@"
+8 KILL ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1)
+9 ;set strength or drug name
IF ORDRUG
IF 'ID
Begin DoDot:1
+10 NEW STR,ITM
SET STR=$PIECE(ID,"&",7)_$PIECE(ID,"&",8)
+11 IF STR'>0
SET ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01)
QUIT
+12 SET ITM=$PIECE($GET(^ORD(101.43,+$GET(OROI),0)),U)
+13 IF ITM'[STR
SET ORDIALOG(ORSTR,1)=STR
End DoDot:1
+14 QUIT
STRT ; Build ORSTRT(inst)=date.time array of start times by dose
+1 NEW OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD
KILL ORSTRT
+2 SET OI=$GET(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM")))
+3 SET PSOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
SET (XD,XH,XM,XS)=0
+4 ;ward
SET ORWD=+$GET(^SC(+$GET(ORL),42))
+5 SET ORI=0
FOR
SET ORI=$ORDER(ORX(ORI))
IF ORI<1
QUIT
Begin DoDot:1
+6 SET SCH=$GET(ORX(ORI,ORSCH))
SET ORSD=""
IF '$LENGTH(SCH)
SET X=$$NOW^XLFDT
+7 IF $LENGTH(SCH)
SET ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD)
SET X=$PIECE(ORSD,U,4)
+8 ;START+OFFSET
SET ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS)
+9 ; update OFFSET for next THEN dose
+10 DO DUR(ORI)
IF $GET(ORX(ORI,ORCONJ))="T"
Begin DoDot:2
+11 ;default duration
IF $GET(ORD("XD"))<1
IF $GET(ORD("XH"))<1
IF $GET(ORD("XM"))<1
IF $GET(ORD("XS"))<1
SET ORD("XD")=+$PIECE(ORSD,U,3)
+12 NEW I,Y
FOR I="XD","XH","XM","XS"
SET Y=@I
SET @I=Y+$GET(ORD(I))
+13 KILL ORD
End DoDot:2
End DoDot:1
+14 ; find beginning date.time for parent
+15 SET ORI=0
SET X=9999999
FOR
SET ORI=$ORDER(ORSTRT(ORI))
IF ORI<1
QUIT
IF ORSTRT(ORI)<X
SET X=ORSTRT(ORI)
+16 SET ORSTRT("BEG")=X
+17 QUIT
DUR(I) ; Accumulate duration in ORD("Xt") for offsetting next THEN dose
+1 NEW X,Y
SET X=$$FMDUR^ORCDPS3($GET(ORX(I,ORDUR)))
+2 IF X["S"
IF +X>$GET(ORD("XS"))
SET ORD("XS")=+X
+3 IF X["'"
IF +X>$GET(ORD("XM"))
SET ORD("XM")=+X
+4 IF X["H"
IF +X>$GET(ORD("XH"))
SET ORD("XH")=+X
+5 SET Y=$SELECT(X["D":+X,X["W":+X*7,X["M":+X*30,1:0)
+6 IF Y
IF Y>$GET(ORD("XD"))
SET ORD("XD")=Y
+7 QUIT
VBEC ; Spawn VBECS children
+1 IF $LENGTH($TEXT(EN^ORCSEND2))
DO EN^ORCSEND2
+2 QUIT
