PSGDL ;BIR/CML3-CALCULATE STOP DATE/TIME WITH DOSE LIMIT ;27 Aug 98 / 8:47 AM
;;5.0;INPATIENT MEDICATIONS;**16,50,64,58,111,170,302,417**;16 DEC 97;Build 3
;
; Reference to ^PS(55 is supported by DBIA #2191.
;
EN ;
K PSGDLS S ND2=^PS(53.1,DA,2) I $P(ND2,"^",5)!$P(ND2,"^",6) W " ...Dose Limit... " G ENGO
G DONE
;
ENE ;
S ND2=PSGSCH_"^"_PSGSD_"^^^"_PSGAT_"^"_PSGS0XT G ENGO
;
EN1 ;
S ND2=$P(PSGNEDFD,"^",4)_"^"_PSGNESD_"^^^"_PSGS0Y_"^"_PSGS0XT G ENGO
;
EN2 ;
K PSGDLS S ND2=^PS(55,DA(1),5,DA,2) I '$P(ND2,"^",5),'$P(ND2,"^",6) G DONE
W " ...Dose Limit... "
;
ENGO ;
S SCH=$P(ND2,"^")
S ST=$S($D(PSGDLS):PSGDLS,1:$P(ND2,"^",2))
S TS=$P(ND2,"^",5),MN=$P(ND2,"^",6)
I $P(PSJSYSW0,U,5)=2 D
. Q:'TS S:TS'[$P(ST,".",2) $P(PSJSYSW0,U,5)=1 D
.. S X=$G(PSGSD),%DT="T" D ^%DT I Y'=-1 N PSGSD S PSGSD=Y
.. S X=$G(PSGFD),%DT="T" D ^%DT I Y'=-1 N PSGFD S PSGFD=Y
.. I '$G(PSGSD) N PSGSD S PSGSD=$$DATE^PSJUTL2
.. I '$G(PSGFD) N PSGFD S PSGFD=$$FMADD^XLFDT(PSGSD,30)
.. ;PSJ 417 move new of TS inside ENQ^PSJORP2
.. N STRING,ND2,SCH,MN S STRING=$G(PSGSD)_"^"_$G(PSGFD)_"^"_$G(PSGSCH)_"^"_$G(PSGST)_"^"_$G(PSGPDRG)_"^"_$G(PSGAT)
.. I $G(PSGP) S ST=$$ENQ^PSJORP2(PSGP,STRING) S:'ST ST=$S($D(PSGDLS):PSGDLS,1:$P(ND2,"^",2))
. S $P(PSJSYSW0,U,5)=2
;PSJ 417 get starting dose for all other orders so admin times are calculated correctly
I $P(PSJSYSW0,U,5)'=2 D
. N INFO S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGAT))
. I $G(PSGP) S ST=$$ENQ^PSJORP2(PSGP,INFO) S:'ST ST=$S($D(PSGDLS):PSGDLS,1:$P(ND2,"^",2))
G MWF:SCH["@",DONE:'TS&'MN
I 'TS S AM=MN*PSGDL,X=$$EN^PSGCT(ST,AM) G DONE
S TM=$E(ST_"00000",9,8+$L($P(TS,"-")))
F Q=1:1 Q:$P(TS,"-",Q)=""!(TM<$P(TS,"-",Q))
S X=ST\1,C=0 F Q=Q:1 D:$P(TS,"-",Q)="" ADD S C=C+1 I C=PSGDL S X=X_"."_$P(TS,"-",Q) G DONE
;
MWF ; if schedule is similar to monday-wednesday-friday
;*302 - PSGDL changed to (PSGDL+1)
S TS=$P(SCH,"@",2),SCH=$P(SCH,"@"),X=$P(ST,"."),C=0 D SCHK G:C=(PSGDL+1) DONE F Q=1:1 S X1=$P(ST,"."),X2=Q D C^%DTC S X1=X D DW^%DTC D CHK G:C=(PSGDL+1) DONE
SCHK S X1=X D DW^%DTC F Q=1:1:$L(SCH,"-") S WKD=$P(SCH,"-",Q) I WKD=$E(X,1,$L(WKD)) Q
E Q
;*302 - < changed to '>
S TM=$E(ST_"00000",9,8+$L($P(TS,"-"))) F Q=1:1:$L(TS,"-") I TM'>$P(TS,"-",Q) S C=C+1 I C=(PSGDL+1) S X=X1_"."_$P(TS,"-",Q) Q
Q
CHK F QQ=1:1:$L(SCH,"-") S WKD=$P(SCH,"-",QQ) I WKD=$E(X,1,$L(WKD)) D TS Q
Q
TS F Q1=1:1:$L(TS,"-") S C=C+1 I C=(PSGDL+1) S X=X1_"."_$P(TS,"-",Q1) Q
Q
;
DONE ;
K %H,%T,%Y,MN,ND2,ND4,PSGDLS,PSGDL,Q1,QQ,SCH,TM,WKD,TS,X1,X2 Q
;
ADD ;
S X1=$P(X,"."),X2=$S(MN&'(MN#1440):MN\1440,1:1) D C^%DTC S Q=1 Q
;
ENPREV ; when "P" is enter at start date
W "REVIOUS" S (X,Y)=0 I '$D(PSGP)!'$D(PSGPDRG) G:$D(DA)[0 POUT S PSGP=$P($G(^PS(53.1,DA,0)),"^",15),PSGPDRG=+$G(^(.2)),Y=1 I 'PSGP!'PSGPDRG W:'PSGPDRG !?17,"Must have drug from formulary list." G POUT
F Q=0:0 S Q=$O(^PS(53.1,"AC",PSGP,Q)) Q:'Q I +$G(^PS(53.1,Q,.2))=PSGPDRG,$D(^PS(53.1,Q,2)),$P(^(2),"^",4)>X S X=$P(^(2),"^",4)
F Q=0:0 S Q=$O(^PS(55,PSGP,5,"C",PSGPDRG,Q)) Q:'Q I $D(^PS(55,PSGP,5,Q,2)),$P(^(2),"^",4)>X S X=$P(^(2),"^",4)
W:'X !?17,"No other order found with this drug."
;
POUT ;
K:'X X K:Y PSGPDRG,PSGP,Q Q
ENDL(SCH,DL) ;validate that dose limit should be allowed with this schedule
;and that the dose limit is a whole number
I $G(SCH)="" Q 1
I ",ON CALL,ON-CALL,ONCALL,"[(","_SCH_",")!($$ONE^PSJBCMA(DFN,"",SCH)="O") W " Dose limit invalid with this schedule" Q 0
I DL'?1N.N W " Dose limit must be a whole number" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGDL 3594 printed Sep 23, 2025@19:37:10 Page 2
PSGDL ;BIR/CML3-CALCULATE STOP DATE/TIME WITH DOSE LIMIT ;27 Aug 98 / 8:47 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**16,50,64,58,111,170,302,417**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA #2191.
+4 ;
EN ;
+1 KILL PSGDLS
SET ND2=^PS(53.1,DA,2)
IF $PIECE(ND2,"^",5)!$PIECE(ND2,"^",6)
WRITE " ...Dose Limit... "
GOTO ENGO
+2 GOTO DONE
+3 ;
ENE ;
+1 SET ND2=PSGSCH_"^"_PSGSD_"^^^"_PSGAT_"^"_PSGS0XT
GOTO ENGO
+2 ;
EN1 ;
+1 SET ND2=$PIECE(PSGNEDFD,"^",4)_"^"_PSGNESD_"^^^"_PSGS0Y_"^"_PSGS0XT
GOTO ENGO
+2 ;
EN2 ;
+1 KILL PSGDLS
SET ND2=^PS(55,DA(1),5,DA,2)
IF '$PIECE(ND2,"^",5)
IF '$PIECE(ND2,"^",6)
GOTO DONE
+2 WRITE " ...Dose Limit... "
+3 ;
ENGO ;
+1 SET SCH=$PIECE(ND2,"^")
+2 SET ST=$SELECT($DATA(PSGDLS):PSGDLS,1:$PIECE(ND2,"^",2))
+3 SET TS=$PIECE(ND2,"^",5)
SET MN=$PIECE(ND2,"^",6)
+4 IF $PIECE(PSJSYSW0,U,5)=2
Begin DoDot:1
+5 if 'TS
QUIT
if TS'[$PIECE(ST,".",2)
SET $PIECE(PSJSYSW0,U,5)=1
Begin DoDot:2
+6 SET X=$GET(PSGSD)
SET %DT="T"
DO ^%DT
IF Y'=-1
NEW PSGSD
SET PSGSD=Y
+7 SET X=$GET(PSGFD)
SET %DT="T"
DO ^%DT
IF Y'=-1
NEW PSGFD
SET PSGFD=Y
+8 IF '$GET(PSGSD)
NEW PSGSD
SET PSGSD=$$DATE^PSJUTL2
+9 IF '$GET(PSGFD)
NEW PSGFD
SET PSGFD=$$FMADD^XLFDT(PSGSD,30)
+10 ;PSJ 417 move new of TS inside ENQ^PSJORP2
+11 NEW STRING,ND2,SCH,MN
SET STRING=$GET(PSGSD)_"^"_$GET(PSGFD)_"^"_$GET(PSGSCH)_"^"_$GET(PSGST)_"^"_$GET(PSGPDRG)_"^"_$GET(PSGAT)
+12 IF $GET(PSGP)
SET ST=$$ENQ^PSJORP2(PSGP,STRING)
if 'ST
SET ST=$SELECT($DATA(PSGDLS):PSGDLS,1:$PIECE(ND2,"^",2))
End DoDot:2
+13 SET $PIECE(PSJSYSW0,U,5)=2
End DoDot:1
+14 ;PSJ 417 get starting dose for all other orders so admin times are calculated correctly
+15 IF $PIECE(PSJSYSW0,U,5)'=2
Begin DoDot:1
+16 NEW INFO
SET INFO=($GET(PSGSD))_U_($GET(PSGFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGPDRG))_U_($GET(PSGAT))
+17 IF $GET(PSGP)
SET ST=$$ENQ^PSJORP2(PSGP,INFO)
if 'ST
SET ST=$SELECT($DATA(PSGDLS):PSGDLS,1:$PIECE(ND2,"^",2))
End DoDot:1
+18 if SCH["@"
GOTO MWF
if 'TS&'MN
GOTO DONE
+19 IF 'TS
SET AM=MN*PSGDL
SET X=$$EN^PSGCT(ST,AM)
GOTO DONE
+20 SET TM=$EXTRACT(ST_"00000",9,8+$LENGTH($PIECE(TS,"-")))
+21 FOR Q=1:1
if $PIECE(TS,"-",Q)=""!(TM<$PIECE(TS,"-",Q))
QUIT
+22 SET X=ST\1
SET C=0
FOR Q=Q:1
if $PIECE(TS,"-",Q)=""
DO ADD
SET C=C+1
IF C=PSGDL
SET X=X_"."_$PIECE(TS,"-",Q)
GOTO DONE
+23 ;
MWF ; if schedule is similar to monday-wednesday-friday
+1 ;*302 - PSGDL changed to (PSGDL+1)
+2 SET TS=$PIECE(SCH,"@",2)
SET SCH=$PIECE(SCH,"@")
SET X=$PIECE(ST,".")
SET C=0
DO SCHK
if C=(PSGDL+1)
GOTO DONE
FOR Q=1:1
SET X1=$PIECE(ST,".")
SET X2=Q
DO C^%DTC
SET X1=X
DO DW^%DTC
DO CHK
if C=(PSGDL+1)
GOTO DONE
SCHK SET X1=X
DO DW^%DTC
FOR Q=1:1:$LENGTH(SCH,"-")
SET WKD=$PIECE(SCH,"-",Q)
IF WKD=$EXTRACT(X,1,$LENGTH(WKD))
QUIT
+1 IF '$TEST
QUIT
+2 ;*302 - < changed to '>
+3 SET TM=$EXTRACT(ST_"00000",9,8+$LENGTH($PIECE(TS,"-")))
FOR Q=1:1:$LENGTH(TS,"-")
IF TM'>$PIECE(TS,"-",Q)
SET C=C+1
IF C=(PSGDL+1)
SET X=X1_"."_$PIECE(TS,"-",Q)
QUIT
+4 QUIT
CHK FOR QQ=1:1:$LENGTH(SCH,"-")
SET WKD=$PIECE(SCH,"-",QQ)
IF WKD=$EXTRACT(X,1,$LENGTH(WKD))
DO TS
QUIT
+1 QUIT
TS FOR Q1=1:1:$LENGTH(TS,"-")
SET C=C+1
IF C=(PSGDL+1)
SET X=X1_"."_$PIECE(TS,"-",Q1)
QUIT
+1 QUIT
+2 ;
DONE ;
+1 KILL %H,%T,%Y,MN,ND2,ND4,PSGDLS,PSGDL,Q1,QQ,SCH,TM,WKD,TS,X1,X2
QUIT
+2 ;
ADD ;
+1 SET X1=$PIECE(X,".")
SET X2=$SELECT(MN&'(MN#1440):MN\1440,1:1)
DO C^%DTC
SET Q=1
QUIT
+2 ;
ENPREV ; when "P" is enter at start date
+1 WRITE "REVIOUS"
SET (X,Y)=0
IF '$DATA(PSGP)!'$DATA(PSGPDRG)
if $DATA(DA)[0
GOTO POUT
SET PSGP=$PIECE($GET(^PS(53.1,DA,0)),"^",15)
SET PSGPDRG=+$GET(^(.2))
SET Y=1
IF 'PSGP!'PSGPDRG
if 'PSGPDRG
WRITE !?17,"Must have drug from formulary list."
GOTO POUT
+2 FOR Q=0:0
SET Q=$ORDER(^PS(53.1,"AC",PSGP,Q))
if 'Q
QUIT
IF +$GET(^PS(53.1,Q,.2))=PSGPDRG
IF $DATA(^PS(53.1,Q,2))
IF $PIECE(^(2),"^",4)>X
SET X=$PIECE(^(2),"^",4)
+3 FOR Q=0:0
SET Q=$ORDER(^PS(55,PSGP,5,"C",PSGPDRG,Q))
if 'Q
QUIT
IF $DATA(^PS(55,PSGP,5,Q,2))
IF $PIECE(^(2),"^",4)>X
SET X=$PIECE(^(2),"^",4)
+4 if 'X
WRITE !?17,"No other order found with this drug."
+5 ;
POUT ;
+1 if 'X
KILL X
if Y
KILL PSGPDRG,PSGP,Q
QUIT
ENDL(SCH,DL) ;validate that dose limit should be allowed with this schedule
+1 ;and that the dose limit is a whole number
+2 IF $GET(SCH)=""
QUIT 1
+3 IF ",ON CALL,ON-CALL,ONCALL,"[(","_SCH_",")!($$ONE^PSJBCMA(DFN,"",SCH)="O")
WRITE " Dose limit invalid with this schedule"
QUIT 0
+4 IF DL'?1N.N
WRITE " Dose limit must be a whole number"
QUIT 0
+5 QUIT 1
