- 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**;16 DEC 97
- ;
- ; 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)
- .. N STRING,ND2,SCH,TS,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
- 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
- S TS=$P(SCH,"@",2),SCH=$P(SCH,"@"),X=$P(ST,"."),C=0 D SCHK G:C=PSGDL 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 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
- 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 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 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
- 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**;16 DEC 97
- +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 NEW STRING,ND2,SCH,TS,MN
- SET STRING=$GET(PSGSD)_"^"_$GET(PSGFD)_"^"_$GET(PSGSCH)_"^"_$GET(PSGST)_"^"_$GET(PSGPDRG)_"^"_$GET(PSGAT)
- +11 IF $GET(PSGP)
- SET ST=$$ENQ^PSJORP2(PSGP,STRING)
- IF 'ST
- SET ST=$SELECT($DATA(PSGDLS):PSGDLS,1:$PIECE(ND2,"^",2))
- End DoDot:2
- +12 SET $PIECE(PSJSYSW0,U,5)=2
- End DoDot:1
- +13 IF SCH["@"
- GOTO MWF
- IF 'TS&'MN
- GOTO DONE
- +14 IF 'TS
- SET AM=MN*PSGDL
- SET X=$$EN^PSGCT(ST,AM)
- GOTO DONE
- +15 SET TM=$EXTRACT(ST_"00000",9,8+$LENGTH($PIECE(TS,"-")))
- +16 FOR Q=1:1
- IF $PIECE(TS,"-",Q)=""!(TM<$PIECE(TS,"-",Q))
- QUIT
- +17 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
- +18 ;
- MWF ; if schedule is similar to monday-wednesday-friday
- +1 SET TS=$PIECE(SCH,"@",2)
- SET SCH=$PIECE(SCH,"@")
- SET X=$PIECE(ST,".")
- SET C=0
- DO SCHK
- IF C=PSGDL
- 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
- 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 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
- SET X=X1_"."_$PIECE(TS,"-",Q)
- QUIT
- +3 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
- 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
