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 Sep 23, 2025@19:44:28 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
