- ORCSEND1 ;SLC/MKB - Release cont ;Aug 31, 2020@16:02:49
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243,282,323,394,435,507,405**;Dec 17, 1997;Build 211
- ;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
- ;
- 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
- 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")
- LR1 N ORLASTC S ORS1=0 F S ORS1=$O(ORX(ORS1)) Q:ORS1'>0 D
- . N ORL S ORL=$P(OR0,U,10) ;protect ORL from calling routine ;DJE/VM *323
- . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE 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:$G(NATURE)'="V" $P(^OR(100,ORPARENT,3),"^",8)=1 ;p394 exclude parent verbal order from veiling
- 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 occurrence
- 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,INDICATN,IND
- 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")
- S INDICATN=$$PTR("INDICATION") ;*405-IND
- 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","INDICATION" D ;*405-IND
- . 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
- . N ORPRR,ORPRA,ORURG
- . S ORURG=$$PTR("URGENCY")
- . S ORPRR=$O(^ORD(101.42,"B","ROUTINE",0))
- . S ORURGID=0,ORURGID=$O(^OR(100,ORIFN,4.5,"ID","URGENCY",ORURGID))
- . I $D(^ORD(101.42,"B","ASAP")) S ORPRA=$O(^ORD(101.42,"B","ASAP",0))
- . I '$D(^ORD(101.42,"B","ASAP")) S ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
- . S:'$G(ORURGID)&$D(^OR(100,ORIFN,4.5,"ID","NOW")) ORURGR=ORPRA,ORDIALOG(ORURG,1)=ORPRA ;RTW
- . S:$G(ORURGID) ORURGR=$P(^OR(100,ORIFN,4.5,ORURGID,1),U,1)
- . S:ORPRA'=ORURGR ORPRA=ORURGR
- . I ORDIALOG(ORURG,1)=ORPRR S ORDIALOG(ORURG,1)=ORPRA
- . D SIG,CHILD^ORCSEND3(ORSTART)
- S IND=$G(ORX(1,INDICATN)) ;405-IND
- F D S ORI=$O(ORX(ORI)) Q:ORI'>0
- . I ORI>1,IND]"" S ORX(ORI,INDICATN)=IND
- . 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))
- . I $G(ORX(1,ORFRST)) D
- . . N ORPRR,ORURG
- . . S ORURG=$$PTR("URGENCY")
- . . S ORPRR=$O(^ORD(101.42,"B","ROUTINE",0))
- . . S ORDIALOG(ORURG,1)=ORPRR
- . 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,ORNOW,ORSP,ORSTP,ORCNJ,ORCNJA,ADMTMN,ADMTM,DURA 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 ORNOW=$$NOW^XLFDT
- S ADMTMN=$$PTR("ADMIN TIMES")
- S ORI=0 F S ORI=$O(ORX(ORI)) Q:ORI<1 D
- . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=ORNOW
- . S ORCNJ=$G(ORX(ORI-1,ORCONJ)),ORCNJA=$$CNJCHK(ORI),ADMTM=$G(ORX(ORI,ADMTMN))
- . I ORCNJA!($L(SCH)&(ORI=1)) D
- . . S ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD,"",ADMTM,ORNOW),X=$P(ORSD,U,4)
- . ;Start Date calculation=1st Start Date: Use Current time or SCH; Subsequent Start Date: T CONJ/Stop Date, A CONJ/Start Date; p*507
- . S ORSTRT(ORI)=$S(ORI=1:X,ORCNJA:X,ORCNJ="T":$G(ORSTP(ORI-1)),1:ORSTRT(ORI-1))
- . S DURA=$$FMDUR^ORCDPS3($G(ORX(ORI,ORDUR)))
- . I DURA["M" S DURA=$TR(DURA,"M","L") ;convert month
- . S ORSTP=$$STOP(ORI,$G(ORSTRT(ORI))),ORSP=$S((DURA["H")&'(+DURA#24):$$STPADM(SCH,ADMTM,ORSTP),"MH'"[$P(DURA,+DURA,2):ORSTP,1:$$STPADM(SCH,ADMTM,ORSTP)),ORSTP(ORI)=ORSP
- ; 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
- STOP(I,ORST) ; calculate STOP DATE; similar to PSJHL9; p*507
- N DURA,STOP
- S DURA=$$FMDUR^ORCDPS3($G(ORX(I,ORDUR))),DURA=$P(DURA,+DURA,2)_+DURA
- I DURA["M" S DURA=$TR(DURA,"M","L") D Q STOP
- . S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(ORST,".")),".")_"."_$P(ORST,".",2) ;convert month
- I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24)
- I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24)
- I +DURA=DURA,DURA["." S DURA="H"_(DURA*24)
- I DURA["'" S DURA="M"_$P(DURA,"'",2)
- S STOP=$$FMADD^XLFDT(ORST,$S(DURA["W":$P(DURA,"W",2)*7,DURA["D":$P(DURA,"D",2),+DURA=DURA:+DURA,1:""),$S(DURA["H":$P(DURA,"H",2),1:""),$S(DURA["M":$P(DURA,"M",2),1:""),$S(DURA["S":$P(DURA,"S",2),1:""))
- Q STOP
- STPADM(SCH,AT,STP) ; calculate STOP DATE based on admin schedule; similar to PSJHL9; p*507
- ;SCH - Schedule, AT - Admin times, STP - Stop Date
- N X,Y,ORTM,OND,ND,AT1
- S STP=+$FN(STP,"",4) S:SCH["PRN" AT=""
- I AT="" Q STP
- I AT?.N D Q AT1
- . S AT1=STP\1_"."_AT I $$FMDIFF^XLFDT(AT1,STP,2)<0 S AT1=$$FMADD^XLFDT(AT1,1) Q
- F Y=1:1 S AT1=$P(AT,"-",Y) Q:'AT1 S ND=STP\1_"."_AT1,ORTM(+ND)=""
- S ND="" F S ND=$O(ORTM(ND)) Q:'ND S X=$$FMDIFF^XLFDT(STP,ND,2) I X<1 S OND=ND Q
- I $D(ORTM),$G(OND)="" Q $O(ORTM(9999999),-1)
- Q $S($G(OND):OND,1:STP)
- CNJCHK(I) ;Check for A conjuction; p*507
- N OI,ORA
- S ORA=1
- F OI=1:1:I I $G(ORX(OI,ORCONJ))="T" S ORA=0 Q
- Q ORA
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCSEND1 12302 printed Jan 18, 2025@03:30:12 Page 2
- ORCSEND1 ;SLC/MKB - Release cont ;Aug 31, 2020@16:02:49
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243,282,323,394,435,507,405**;Dec 17, 1997;Build 211
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;Reference to PSJEEU supported by IA #486
- +5 ;Reference to PSJORPOE supported by IA #3167
- +6 ;
- 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 SET ORPARENT=+ORIFN
- SET OR0=$GET(^OR(100,ORIFN,0))
- SET ORL=$PIECE(OR0,U,10)
- +3 DO SCHEDULE(ORIFN,"LR",.ORSTRT)
- IF ORSTRT'>1
- Begin DoDot:1
- +4 NEW START
- SET START=$ORDER(ORSTRT(0))
- if START=$PIECE($GET(^OR(100,+ORIFN,0)),U,8)
- QUIT
- +5 ;update start date from schedule
- DO DATES^ORCSAVE2(+ORIFN,START)
- End DoDot:1
- QUIT
- +6 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)
- +7 DO GETDLG1^ORCD(ORDIALOG)
- DO GETORDER(ORIFN)
- DO GETIMES^ORCDLR1
- +8 KILL ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1)
- +9 SET ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
- +10 SET ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE")
- +11 SET ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN")
- +12 SET ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY")
- +13 SET ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
- +14 SET ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE")
- +15 SET ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME")
- LR1 NEW ORLASTC
- SET ORS1=0
- FOR
- SET ORS1=$ORDER(ORX(ORS1))
- if ORS1'>0
- QUIT
- Begin DoDot:1
- +1 ;protect ORL from calling routine ;DJE/VM *323
- NEW ORL
- SET ORL=$PIECE(OR0,U,10)
- +2 ;set values to next instance
- FOR P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE
- 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 ;p394 exclude parent verbal order from veiling
- DO DATES^ORCSAVE2(ORPARENT,,ORLASTC)
- if $GET(NATURE)'="V"
- 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 occurrence
- 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,INDICATN,IND
- +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 ;*405-IND
- SET INDICATN=$$PTR("INDICATION")
- +18 IF $PIECE(OR3,U,11)=2
- IF $ORDER(^OR(100,+$PIECE(OR3,U,5),2,0))
- Begin DoDot:1
- +19 SET ORENEW=+$PIECE(OR3,U,5)
- SET I=0
- +20 IF $$VALUE^ORX8(ORENEW,"NOW")
- SET I=$ORDER(^OR(100,ORENEW,2,0))
- +21 FOR
- SET I=$ORDER(^OR(100,ORENEW,2,I))
- if I<1
- QUIT
- SET ORENEW(I)=""
- End DoDot:1
- PS1 ;*405-IND
- FOR ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1","INDICATION"
- 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 NEW ORPRR,ORPRA,ORURG
- +8 SET ORURG=$$PTR("URGENCY")
- +9 SET ORPRR=$ORDER(^ORD(101.42,"B","ROUTINE",0))
- +10 SET ORURGID=0
- SET ORURGID=$ORDER(^OR(100,ORIFN,4.5,"ID","URGENCY",ORURGID))
- +11 IF $DATA(^ORD(101.42,"B","ASAP"))
- SET ORPRA=$ORDER(^ORD(101.42,"B","ASAP",0))
- +12 IF '$DATA(^ORD(101.42,"B","ASAP"))
- SET ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
- +13 ;RTW
- if '$GET(ORURGID)&$DATA(^OR(100,ORIFN,4.5,"ID","NOW"))
- SET ORURGR=ORPRA
- SET ORDIALOG(ORURG,1)=ORPRA
- +14 if $GET(ORURGID)
- SET ORURGR=$PIECE(^OR(100,ORIFN,4.5,ORURGID,1),U,1)
- +15 if ORPRA'=ORURGR
- SET ORPRA=ORURGR
- +16 IF ORDIALOG(ORURG,1)=ORPRR
- SET ORDIALOG(ORURG,1)=ORPRA
- +17 DO SIG
- DO CHILD^ORCSEND3(ORSTART)
- End DoDot:1
- +18 ;405-IND
- SET IND=$GET(ORX(1,INDICATN))
- +19 FOR
- Begin DoDot:1
- +20 IF ORI>1
- IF IND]""
- SET ORX(ORI,INDICATN)=IND
- +21 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)
- +22 KILL ORDIALOG(ORDD,1)
- SET ID=$GET(ORX(ORI,ORID))
- +23 if $PIECE(ID,"&",6)
- SET ORDIALOG(ORDD,1)=$PIECE(ID,"&",6)
- +24 SET ORSTART=$GET(ORSTRT(ORI))
- +25 IF $GET(ORX(1,ORFRST))
- Begin DoDot:2
- +26 NEW ORPRR,ORURG
- +27 SET ORURG=$$PTR("URGENCY")
- +28 SET ORPRR=$ORDER(^ORD(101.42,"B","ROUTINE",0))
- +29 SET ORDIALOG(ORURG,1)=ORPRR
- End DoDot:2
- +30 DO SIG
- DO CHILD^ORCSEND3(ORSTART)
- End DoDot:1
- SET ORI=$ORDER(ORX(ORI))
- if ORI'>0
- QUIT
- +31 if $GET(ORCHLD)
- SET ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
- +32 SET ORIFN=ORPARENT
- SET ORQUIT=1
- SET OR3=$GET(^OR(100,ORIFN,3))
- SET STS=$PIECE(OR3,U,3)
- +33 IF (STS=1)!(STS=13)!(STS=11)
- SET ORERR="1^Unable to release orders"
- +34 DO RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$GET(NATURE))
- KILL ^TMP("ORWORD",$JOB)
- +35 ;veil parent order - set stop date/time?
- SET $PIECE(^OR(100,ORIFN,3),U,8)=1
- +36 ;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,ORNOW,ORSP,ORSTP,ORCNJ,ORCNJA,ADMTMN,ADMTM,DURA
- 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 ORNOW=$$NOW^XLFDT
- +6 SET ADMTMN=$$PTR("ADMIN TIMES")
- +7 SET ORI=0
- FOR
- SET ORI=$ORDER(ORX(ORI))
- if ORI<1
- QUIT
- Begin DoDot:1
- +8 SET SCH=$GET(ORX(ORI,ORSCH))
- SET ORSD=""
- if '$LENGTH(SCH)
- SET X=ORNOW
- +9 SET ORCNJ=$GET(ORX(ORI-1,ORCONJ))
- SET ORCNJA=$$CNJCHK(ORI)
- SET ADMTM=$GET(ORX(ORI,ADMTMN))
- +10 IF ORCNJA!($LENGTH(SCH)&(ORI=1))
- Begin DoDot:2
- +11 SET ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD,"",ADMTM,ORNOW)
- SET X=$PIECE(ORSD,U,4)
- End DoDot:2
- +12 ;Start Date calculation=1st Start Date: Use Current time or SCH; Subsequent Start Date: T CONJ/Stop Date, A CONJ/Start Date; p*507
- +13 SET ORSTRT(ORI)=$SELECT(ORI=1:X,ORCNJA:X,ORCNJ="T":$GET(ORSTP(ORI-1)),1:ORSTRT(ORI-1))
- +14 SET DURA=$$FMDUR^ORCDPS3($GET(ORX(ORI,ORDUR)))
- +15 ;convert month
- IF DURA["M"
- SET DURA=$TRANSLATE(DURA,"M","L")
- +16 SET ORSTP=$$STOP(ORI,$GET(ORSTRT(ORI)))
- SET ORSP=$SELECT((DURA["H")&'(+DURA#24):$$STPADM(SCH,ADMTM,ORSTP),"MH'"[$PIECE(DURA,+DURA,2):ORSTP,1:$$STPADM(SCH,ADMTM,ORSTP))
- SET ORSTP(ORI)=ORSP
- End DoDot:1
- +17 ; find beginning date.time for parent
- +18 SET ORI=0
- SET X=9999999
- FOR
- SET ORI=$ORDER(ORSTRT(ORI))
- if ORI<1
- QUIT
- IF ORSTRT(ORI)<X
- SET X=ORSTRT(ORI)
- +19 SET ORSTRT("BEG")=X
- +20 QUIT
- STOP(I,ORST) ; calculate STOP DATE; similar to PSJHL9; p*507
- +1 NEW DURA,STOP
- +2 SET DURA=$$FMDUR^ORCDPS3($GET(ORX(I,ORDUR)))
- SET DURA=$PIECE(DURA,+DURA,2)_+DURA
- +3 IF DURA["M"
- SET DURA=$TRANSLATE(DURA,"M","L")
- Begin DoDot:1
- +4 ;convert month
- SET STOP=$PIECE($$SCH^XLFDT($PIECE(DURA,"L",2)_"M",$PIECE(ORST,".")),".")_"."_$PIECE(ORST,".",2)
- End DoDot:1
- QUIT STOP
- +5 IF DURA["W"
- IF DURA["."
- SET DURA="H"_(($PIECE(DURA,"W",2)*7)*24)
- +6 IF DURA["D"
- IF DURA["."
- SET DURA="H"_($PIECE(DURA,"D",2)*24)
- +7 IF +DURA=DURA
- IF DURA["."
- SET DURA="H"_(DURA*24)
- +8 IF DURA["'"
- SET DURA="M"_$PIECE(DURA,"'",2)
- +9 SET STOP=$$FMADD^XLFDT(ORST,$SELECT(DURA["W":$PIECE(DURA,"W",2)*7,DURA["D":$PIECE(DURA,"D",2),+DURA=DURA:+DURA,1:""),$SELECT(DURA["H":$PIECE(DURA,"H",2),1:""),$SELECT(DURA["M":$PIECE(DURA,"M",2),1:""),$SELECT(DURA["S":$PIECE(DURA,"S",2),1:""))
- +10 QUIT STOP
- STPADM(SCH,AT,STP) ; calculate STOP DATE based on admin schedule; similar to PSJHL9; p*507
- +1 ;SCH - Schedule, AT - Admin times, STP - Stop Date
- +2 NEW X,Y,ORTM,OND,ND,AT1
- +3 SET STP=+$FNUMBER(STP,"",4)
- if SCH["PRN"
- SET AT=""
- +4 IF AT=""
- QUIT STP
- +5 IF AT?.N
- Begin DoDot:1
- +6 SET AT1=STP\1_"."_AT
- IF $$FMDIFF^XLFDT(AT1,STP,2)<0
- SET AT1=$$FMADD^XLFDT(AT1,1)
- QUIT
- End DoDot:1
- QUIT AT1
- +7 FOR Y=1:1
- SET AT1=$PIECE(AT,"-",Y)
- if 'AT1
- QUIT
- SET ND=STP\1_"."_AT1
- SET ORTM(+ND)=""
- +8 SET ND=""
- FOR
- SET ND=$ORDER(ORTM(ND))
- if 'ND
- QUIT
- SET X=$$FMDIFF^XLFDT(STP,ND,2)
- IF X<1
- SET OND=ND
- QUIT
- +9 IF $DATA(ORTM)
- IF $GET(OND)=""
- QUIT $ORDER(ORTM(9999999),-1)
- +10 QUIT $SELECT($GET(OND):OND,1:STP)
- CNJCHK(I) ;Check for A conjuction; p*507
- +1 NEW OI,ORA
- +2 SET ORA=1
- +3 FOR OI=1:1:I
- IF $GET(ORX(OI,ORCONJ))="T"
- SET ORA=0
- QUIT
- +4 QUIT ORA
- 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