- PSJORP2 ;BIR/JCH-CALCULATE FIRST DOSE FOR OE/RR 3.0 ; 4/12/10 8:59am
- ;;5.0;INPATIENT MEDICATIONS ;**80,110,111,133,189,237,417**;16 DEC 97;Build 3
- ;
- Q
- ENQ(PSGP,INFO) ; start
- ; INFO (piece 1) = START DATE/TIME
- ; INFO (piece 2) = STOP DATE/TIME
- ; INFO (piece 3) = SCHEDULE
- ; INFO (piece 4) = SCHEDULE TYPE
- ; INFO (piece 5) = ORDERABLE ITEM
- ; INFO (piece 6) = ADMIN TIMES
- ;
- ;PSJ 417 new TS
- N PSGNESD,PSGSD,PSGNEFD,PSGFD,PSGSCH,PSGST,PST,PSGS0XT,PSGS0Y,PSGED,SCHFREQ,FIRST,PSGDF,PSGS,PSGSTODD,TS
- S (PSGSD,PSGNESD)=$P(INFO,U),(PSGFD,PSGNEFD)=$P(INFO,U,2),PSGSCH=$P(INFO,U,3),(PSGST,PST)=$P(INFO,U,4),PSGS0Y=$P(INFO,U,6)
- S PSGST=$S(PSGST="O":"O",1:"C"),PSGS0XT="",FIRST=""
- Q:'PSGSD "" S X=PSGSCH D ADMIN^PSJORPOE
- I ($P(INFO,"^",6)]""),($G(PSGS0Y)'=$P(INFO,"^",6)) S PSGS0Y=$P(INFO,"^",6)
- I $G(PSJLSTAT),'$G(PSGS0XT),'$$DOW^PSIVUTL(PSGSCH) D
- .N D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0Y,PSGDT S X=$P(INFO,"^",3) I X]"" S PSGOES=1 D EN^PSGORS0
- I '$G(PSJLSTAT) S X2=$S(PSGS0XT>1440:(PSGS0XT\1440)+1,1:7),X1=PSGSD D C^%DTC S (PSGFD,PSGNEFD)=X
- I 'PSGS0Y S:PSGSCH["@" PSGS0Y=$P(PSGSCH,"@",2) I 'PSGS0Y S PSGS0Y=$P(PSGSD,".",2) I $G(PSGST)'="O",($E(PSGS0Y,1,2)<23),($P($G(PSJSYSW0),"^",5)=1) D
- . I $L($P(PSGSD,".",2))<3 S DCAL=$P(PSGSD,".",2) Q
- . N DCAL S DCAL=$E($$FMADD^XLFDT(PSGSD,0,1,0,0),9,10) S:DCAL PSGS0Y=DCAL
- S PSGS=$S(PSGST="C":1,PSGST="P":2,PSGST="O":4,1:"")
- S X2=PSGNESD,X1=PSGNEFD D ^%DTC S PSGDF=X+30
- K PSGD S X=$P(PSGSD,"."),PSGDW="" F Q=0:1:PSGDF-1 S X1=$P(PSGSD,"."),X2=Q D:Q C^%DTC S PSGD(X)=$E(X,4,5)_"/"_$E(X,6,7),HX=X D DW^%DTC S $P(PSGD(HX),U,2)=X
- D NOW^%DTC S PSGDT=%
- S PST=PSGST,PSGED=PSGSD D OS(PSGP,PSGST)
- I $D(PSGD)<10 Q ""
- D PRT(X) I $G(PSJLSTAT) S:$G(LAST)>PSGFD LAST=PSGFD Q +$G(LAST)
- I $G(FIRST)<PSGSD S FIRST=PSGSD
- I $P(PSGSD,".")=$P(FIRST,"."),($P($G(^PS(59.6,+$G(PSJPWD),0)),"^",5)=2),'$G(PSGS0Y) S FIRST=PSGSD
- K PSGD,TS,PSGGD,X,S,Q,QQ,QST
- Q FIRST
- ;
- OS(PSGP,PSGST) ; order record set
- S SD=PSGNESD I $S($P(SD,".")>PSGNEFD:1,PSGS=1:PSGSCH["PRN",1:0) Q
- S FD=PSGNEFD,T=PSGS0XT
- S QST=$S(PST="C"!(PST="O"):PST,PST="OC":"OA",PST="P":"OP",PSGSCH["PRN":"OR",1:"CR")
- S QQ="" I QST["C" D DTS(PSGSCH) S SD=$P(SD,"."),QQ="" F X=0:0 S X=$O(PSGD(X)) Q:'X D
- . S QQ=QQ_$S(X<SD:"",X>FD:"",'S:$P(PSGD(X),U),$D(S(X)):$P(PSGD(X),U),1:"")
- I PSGS0XT="D",PSGS0Y="" S PSGS0Y=$P(PSGNESD,".",2)
- S X=$S(QST["C"!(QST="O"):PSGS0Y,1:"")_U_QQ
- Q
- ;
- DTS(SCHEDULE) ;
- K S S S=0 I SCHEDULE["@"!(PSGST="D") S WD=$S(SCHEDULE["@":$P(SCHEDULE,"@"),1:SCHEDULE) D
- . F Q=0:0 S Q=$O(PSGD(Q)) Q:'Q F QQ=1:1:$L(WD,"-") I $P($P(PSGD(Q),U,2),$P(WD,"-",QQ))="" S S(Q)="",S=S+1 Q
- Q:SCHEDULE["@"!(T="D") Q:T'>1440 S WD=$P(PSGSD,".") I '(T#1440) S SD=$P(SD,"."),X=$S($G(PSGOSD):$P(PSGOSD,"."),1:SD),PSGT=T\1440 D ;*237 Changed X to PSGOSD if it exists
- . F QQ=0:1 S X1=$S($G(PSGOSD):$P(PSGOSD,"."),1:SD),X2=QQ*PSGT S:'X2 X=X1 D:X2 C^%DTC I X'<WD S S=S+1 Q:X>PSGFD Q:X>FD S S(X)="" ;*237 Changed X1 to PSGOSD if it exists
- K PSGT Q:'(T#1440) S PSGT=T,X1=PSGSD,(ST,X2)=SD I PSGSD>SD D ^%DTC I X>1 S ST=$$EN^PSGCT(SD,X-1*1440\T*T)
- S (PSGS,X)=ST F PSGX=0:1 S AM=PSGT*PSGX,(ST,X)=$S($G(PSGOSD):PSGOSD,1:PSGS) S:AM X=$$EN^PSGCT(ST,AM) S PSGSTODD(PSGX+1)=X S X=$P(X,".") I X'<WD Q:X>PSGFD Q:X>FD I '$D(S(X)) S S=S+1,S(X)="" ;*237 Changed ST,X to PSGOSD, added PSGSTODD
- K AM,ST,PSGS,PSGT,PSGX Q
- ;
- PRT(PSGTS) ; order info
- S PSGGD=$P(PSGTS,"^",2),PSGTS=$P(PSGTS,"^") S PSJPSTO=PST
- D TS(PSGTS) D FIRST D:$G(PSJLSTAT) LAST
- S PSGOC=$G(PSGOC)+1
- Q
- ;
- FIRST ; find expected first dose
- N QTS,ADMIN S FIRST=""
- I PST["CZ" NEW PSGLFFD,PSGGD S P(9)="",PSGLFFD="9999999",PSGGD="" Q
- I TS=1,'PSGTS Q
- ;*237 If frequency is >, but not a multiple of, 24 hours, and no admin times
- I $D(PSGSTODD),$G(PSGOSD),$P(INFO,U,6)="" F Q=0:0 S Q=$O(PSGSTODD(Q)) Q:'Q!$G(FIRST) D
- . S QTS=PSGSTODD(Q)
- . S FIRST=$S(QTS<PSGSD:"",QTS'<PSGFD:"",1:QTS)
- Q:FIRST
- F Q=0:0 S Q=$O(PSGD(Q)) Q:'Q!$G(FIRST) S ADMIN=0 F S ADMIN=$O(TS(ADMIN)) Q:'ADMIN!$G(FIRST) D
- . S QTS=Q_"."_TS(ADMIN)
- . S FIRST=$S(QTS<PSGSD:"",QTS'<PSGFD:"",PSGGD="":"",PSGGD[$P(PSGD(Q),"^"):QTS,1:"")
- Q
- ;
- LAST ; find expected last dose
- N QTS,ADMIN S LAST=""
- I PST["CZ" NEW PSGLFFD,PSGGD S P(9)="",PSGLFFD="9999999",PSGGD="" Q
- I TS=1,'PSGTS Q
- S Q=99999999 F S Q=$O(PSGD(Q),-1) Q:'Q!$G(LAST) S ADMIN="" F S ADMIN=$O(TS(ADMIN),-1) Q:'ADMIN!$G(LAST) D
- . S QTS=Q_"."_TS(ADMIN)
- . S LAST=$S(QTS>PSGFD:"",QTS'>PSGSD:"",PSGGD="":"",PSGGD[$P(PSGD(Q),"^"):QTS,1:"")
- Q
- ;
- TS(X) ;
- K TS S TS=$L(X,"-") F Q=1:1:TS S TS(Q)=$P(X,"-",Q)
- Q
- ;
- LASTAT(PSGP,INFO) ;
- N LSTDT,PSJLSTAT S LASTAT=0,PSJLSTAT=1 S LASTAT=$$ENQ(PSGP,INFO)
- I (LASTAT>$P(INFO,"^",2)!'LASTAT) S LASTAT=$P(INFO,"^",2)
- K PSGD,TS,PSGGD,X,S,Q,QQ,QST
- Q LASTAT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORP2 4796 printed Feb 18, 2025@23:34:43 Page 2
- PSJORP2 ;BIR/JCH-CALCULATE FIRST DOSE FOR OE/RR 3.0 ; 4/12/10 8:59am
- +1 ;;5.0;INPATIENT MEDICATIONS ;**80,110,111,133,189,237,417**;16 DEC 97;Build 3
- +2 ;
- +3 QUIT
- ENQ(PSGP,INFO) ; start
- +1 ; INFO (piece 1) = START DATE/TIME
- +2 ; INFO (piece 2) = STOP DATE/TIME
- +3 ; INFO (piece 3) = SCHEDULE
- +4 ; INFO (piece 4) = SCHEDULE TYPE
- +5 ; INFO (piece 5) = ORDERABLE ITEM
- +6 ; INFO (piece 6) = ADMIN TIMES
- +7 ;
- +8 ;PSJ 417 new TS
- +9 NEW PSGNESD,PSGSD,PSGNEFD,PSGFD,PSGSCH,PSGST,PST,PSGS0XT,PSGS0Y,PSGED,SCHFREQ,FIRST,PSGDF,PSGS,PSGSTODD,TS
- +10 SET (PSGSD,PSGNESD)=$PIECE(INFO,U)
- SET (PSGFD,PSGNEFD)=$PIECE(INFO,U,2)
- SET PSGSCH=$PIECE(INFO,U,3)
- SET (PSGST,PST)=$PIECE(INFO,U,4)
- SET PSGS0Y=$PIECE(INFO,U,6)
- +11 SET PSGST=$SELECT(PSGST="O":"O",1:"C")
- SET PSGS0XT=""
- SET FIRST=""
- +12 if 'PSGSD
- QUIT ""
- SET X=PSGSCH
- DO ADMIN^PSJORPOE
- +13 IF ($PIECE(INFO,"^",6)]"")
- IF ($GET(PSGS0Y)'=$PIECE(INFO,"^",6))
- SET PSGS0Y=$PIECE(INFO,"^",6)
- +14 IF $GET(PSJLSTAT)
- IF '$GET(PSGS0XT)
- IF '$$DOW^PSIVUTL(PSGSCH)
- Begin DoDot:1
- +15 NEW D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0Y,PSGDT
- SET X=$PIECE(INFO,"^",3)
- IF X]""
- SET PSGOES=1
- DO EN^PSGORS0
- End DoDot:1
- +16 IF '$GET(PSJLSTAT)
- SET X2=$SELECT(PSGS0XT>1440:(PSGS0XT\1440)+1,1:7)
- SET X1=PSGSD
- DO C^%DTC
- SET (PSGFD,PSGNEFD)=X
- +17 IF 'PSGS0Y
- if PSGSCH["@"
- SET PSGS0Y=$PIECE(PSGSCH,"@",2)
- IF 'PSGS0Y
- SET PSGS0Y=$PIECE(PSGSD,".",2)
- IF $GET(PSGST)'="O"
- IF ($EXTRACT(PSGS0Y,1,2)<23)
- IF ($PIECE($GET(PSJSYSW0),"^",5)=1)
- Begin DoDot:1
- +18 IF $LENGTH($PIECE(PSGSD,".",2))<3
- SET DCAL=$PIECE(PSGSD,".",2)
- QUIT
- +19 NEW DCAL
- SET DCAL=$EXTRACT($$FMADD^XLFDT(PSGSD,0,1,0,0),9,10)
- if DCAL
- SET PSGS0Y=DCAL
- End DoDot:1
- +20 SET PSGS=$SELECT(PSGST="C":1,PSGST="P":2,PSGST="O":4,1:"")
- +21 SET X2=PSGNESD
- SET X1=PSGNEFD
- DO ^%DTC
- SET PSGDF=X+30
- +22 KILL PSGD
- SET X=$PIECE(PSGSD,".")
- SET PSGDW=""
- FOR Q=0:1:PSGDF-1
- SET X1=$PIECE(PSGSD,".")
- SET X2=Q
- if Q
- DO C^%DTC
- SET PSGD(X)=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)
- SET HX=X
- DO DW^%DTC
- SET $PIECE(PSGD(HX),U,2)=X
- +23 DO NOW^%DTC
- SET PSGDT=%
- +24 SET PST=PSGST
- SET PSGED=PSGSD
- DO OS(PSGP,PSGST)
- +25 IF $DATA(PSGD)<10
- QUIT ""
- +26 DO PRT(X)
- IF $GET(PSJLSTAT)
- if $GET(LAST)>PSGFD
- SET LAST=PSGFD
- QUIT +$GET(LAST)
- +27 IF $GET(FIRST)<PSGSD
- SET FIRST=PSGSD
- +28 IF $PIECE(PSGSD,".")=$PIECE(FIRST,".")
- IF ($PIECE($GET(^PS(59.6,+$GET(PSJPWD),0)),"^",5)=2)
- IF '$GET(PSGS0Y)
- SET FIRST=PSGSD
- +29 KILL PSGD,TS,PSGGD,X,S,Q,QQ,QST
- +30 QUIT FIRST
- +31 ;
- OS(PSGP,PSGST) ; order record set
- +1 SET SD=PSGNESD
- IF $SELECT($PIECE(SD,".")>PSGNEFD:1,PSGS=1:PSGSCH["PRN",1:0)
- QUIT
- +2 SET FD=PSGNEFD
- SET T=PSGS0XT
- +3 SET QST=$SELECT(PST="C"!(PST="O"):PST,PST="OC":"OA",PST="P":"OP",PSGSCH["PRN":"OR",1:"CR")
- +4 SET QQ=""
- IF QST["C"
- DO DTS(PSGSCH)
- SET SD=$PIECE(SD,".")
- SET QQ=""
- FOR X=0:0
- SET X=$ORDER(PSGD(X))
- if 'X
- QUIT
- Begin DoDot:1
- +5 SET QQ=QQ_$SELECT(X<SD:"",X>FD:"",'S:$PIECE(PSGD(X),U),$DATA(S(X)):$PIECE(PSGD(X),U),1:"")
- End DoDot:1
- +6 IF PSGS0XT="D"
- IF PSGS0Y=""
- SET PSGS0Y=$PIECE(PSGNESD,".",2)
- +7 SET X=$SELECT(QST["C"!(QST="O"):PSGS0Y,1:"")_U_QQ
- +8 QUIT
- +9 ;
- DTS(SCHEDULE) ;
- +1 KILL S
- SET S=0
- IF SCHEDULE["@"!(PSGST="D")
- SET WD=$SELECT(SCHEDULE["@":$PIECE(SCHEDULE,"@"),1:SCHEDULE)
- Begin DoDot:1
- +2 FOR Q=0:0
- SET Q=$ORDER(PSGD(Q))
- if 'Q
- QUIT
- FOR QQ=1:1:$LENGTH(WD,"-")
- IF $PIECE($PIECE(PSGD(Q),U,2),$PIECE(WD,"-",QQ))=""
- SET S(Q)=""
- SET S=S+1
- QUIT
- End DoDot:1
- +3 ;*237 Changed X to PSGOSD if it exists
- if SCHEDULE["@"!(T="D")
- QUIT
- if T'>1440
- QUIT
- SET WD=$PIECE(PSGSD,".")
- IF '(T#1440)
- SET SD=$PIECE(SD,".")
- SET X=$SELECT($GET(PSGOSD):$PIECE(PSGOSD,"."),1:SD)
- SET PSGT=T\1440
- Begin DoDot:1
- +4 ;*237 Changed X1 to PSGOSD if it exists
- FOR QQ=0:1
- SET X1=$SELECT($GET(PSGOSD):$PIECE(PSGOSD,"."),1:SD)
- SET X2=QQ*PSGT
- if 'X2
- SET X=X1
- if X2
- DO C^%DTC
- IF X'<WD
- SET S=S+1
- if X>PSGFD
- QUIT
- if X>FD
- QUIT
- SET S(X)=""
- End DoDot:1
- +5 KILL PSGT
- if '(T#1440)
- QUIT
- SET PSGT=T
- SET X1=PSGSD
- SET (ST,X2)=SD
- IF PSGSD>SD
- DO ^%DTC
- IF X>1
- SET ST=$$EN^PSGCT(SD,X-1*1440\T*T)
- +6 ;*237 Changed ST,X to PSGOSD, added PSGSTODD
- SET (PSGS,X)=ST
- FOR PSGX=0:1
- SET AM=PSGT*PSGX
- SET (ST,X)=$SELECT($GET(PSGOSD):PSGOSD,1:PSGS)
- if AM
- SET X=$$EN^PSGCT(ST,AM)
- SET PSGSTODD(PSGX+1)=X
- SET X=$PIECE(X,".")
- IF X'<WD
- if X>PSGFD
- QUIT
- if X>FD
- QUIT
- IF '$DATA(S(X))
- SET S=S+1
- SET S(X)=""
- +7 KILL AM,ST,PSGS,PSGT,PSGX
- QUIT
- +8 ;
- PRT(PSGTS) ; order info
- +1 SET PSGGD=$PIECE(PSGTS,"^",2)
- SET PSGTS=$PIECE(PSGTS,"^")
- SET PSJPSTO=PST
- +2 DO TS(PSGTS)
- DO FIRST
- if $GET(PSJLSTAT)
- DO LAST
- +3 SET PSGOC=$GET(PSGOC)+1
- +4 QUIT
- +5 ;
- FIRST ; find expected first dose
- +1 NEW QTS,ADMIN
- SET FIRST=""
- +2 IF PST["CZ"
- NEW PSGLFFD,PSGGD
- SET P(9)=""
- SET PSGLFFD="9999999"
- SET PSGGD=""
- QUIT
- +3 IF TS=1
- IF 'PSGTS
- QUIT
- +4 ;*237 If frequency is >, but not a multiple of, 24 hours, and no admin times
- +5 IF $DATA(PSGSTODD)
- IF $GET(PSGOSD)
- IF $PIECE(INFO,U,6)=""
- FOR Q=0:0
- SET Q=$ORDER(PSGSTODD(Q))
- if 'Q!$GET(FIRST)
- QUIT
- Begin DoDot:1
- +6 SET QTS=PSGSTODD(Q)
- +7 SET FIRST=$SELECT(QTS<PSGSD:"",QTS'<PSGFD:"",1:QTS)
- End DoDot:1
- +8 if FIRST
- QUIT
- +9 FOR Q=0:0
- SET Q=$ORDER(PSGD(Q))
- if 'Q!$GET(FIRST)
- QUIT
- SET ADMIN=0
- FOR
- SET ADMIN=$ORDER(TS(ADMIN))
- if 'ADMIN!$GET(FIRST)
- QUIT
- Begin DoDot:1
- +10 SET QTS=Q_"."_TS(ADMIN)
- +11 SET FIRST=$SELECT(QTS<PSGSD:"",QTS'<PSGFD:"",PSGGD="":"",PSGGD[$PIECE(PSGD(Q),"^"):QTS,1:"")
- End DoDot:1
- +12 QUIT
- +13 ;
- LAST ; find expected last dose
- +1 NEW QTS,ADMIN
- SET LAST=""
- +2 IF PST["CZ"
- NEW PSGLFFD,PSGGD
- SET P(9)=""
- SET PSGLFFD="9999999"
- SET PSGGD=""
- QUIT
- +3 IF TS=1
- IF 'PSGTS
- QUIT
- +4 SET Q=99999999
- FOR
- SET Q=$ORDER(PSGD(Q),-1)
- if 'Q!$GET(LAST)
- QUIT
- SET ADMIN=""
- FOR
- SET ADMIN=$ORDER(TS(ADMIN),-1)
- if 'ADMIN!$GET(LAST)
- QUIT
- Begin DoDot:1
- +5 SET QTS=Q_"."_TS(ADMIN)
- +6 SET LAST=$SELECT(QTS>PSGFD:"",QTS'>PSGSD:"",PSGGD="":"",PSGGD[$PIECE(PSGD(Q),"^"):QTS,1:"")
- End DoDot:1
- +7 QUIT
- +8 ;
- TS(X) ;
- +1 KILL TS
- SET TS=$LENGTH(X,"-")
- FOR Q=1:1:TS
- SET TS(Q)=$PIECE(X,"-",Q)
- +2 QUIT
- +3 ;
- LASTAT(PSGP,INFO) ;
- +1 NEW LSTDT,PSJLSTAT
- SET LASTAT=0
- SET PSJLSTAT=1
- SET LASTAT=$$ENQ(PSGP,INFO)
- +2 IF (LASTAT>$PIECE(INFO,"^",2)!'LASTAT)
- SET LASTAT=$PIECE(INFO,"^",2)
- +3 KILL PSGD,TS,PSGGD,X,S,Q,QQ,QST
- +4 QUIT LASTAT