source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGDL.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1PSGDL ;BIR/CML3-CALCULATE STOP DATE/TIME WITH DOSE LIMIT ;27 Aug 98 / 8:47 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**16,50,64,58,111,170**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA #2191.
5 ;
6EN ;
7 K PSGDLS S ND2=^PS(53.1,DA,2) I $P(ND2,"^",5)!$P(ND2,"^",6) W " ...Dose Limit... " G ENGO
8 G DONE
9 ;
10ENE ;
11 S ND2=PSGSCH_"^"_PSGSD_"^^^"_PSGAT_"^"_PSGS0XT G ENGO
12 ;
13EN1 ;
14 S ND2=$P(PSGNEDFD,"^",4)_"^"_PSGNESD_"^^^"_PSGS0Y_"^"_PSGS0XT G ENGO
15 ;
16EN2 ;
17 K PSGDLS S ND2=^PS(55,DA(1),5,DA,2) I '$P(ND2,"^",5),'$P(ND2,"^",6) G DONE
18 W " ...Dose Limit... "
19 ;
20ENGO ;
21 S SCH=$P(ND2,"^")
22 S ST=$S($D(PSGDLS):PSGDLS,1:$P(ND2,"^",2))
23 S TS=$P(ND2,"^",5),MN=$P(ND2,"^",6)
24 I $P(PSJSYSW0,U,5)=2 D
25 . Q:'TS S:TS'[$P(ST,".",2) $P(PSJSYSW0,U,5)=1 D
26 .. S X=$G(PSGSD),%DT="T" D ^%DT I Y'=-1 N PSGSD S PSGSD=Y
27 .. S X=$G(PSGFD),%DT="T" D ^%DT I Y'=-1 N PSGFD S PSGFD=Y
28 .. I '$G(PSGSD) N PSGSD S PSGSD=$$DATE^PSJUTL2
29 .. I '$G(PSGFD) N PSGFD S PSGFD=$$FMADD^XLFDT(PSGSD,30)
30 .. N STRING,ND2,SCH,TS,MN S STRING=$G(PSGSD)_"^"_$G(PSGFD)_"^"_$G(PSGSCH)_"^"_$G(PSGST)_"^"_$G(PSGPDRG)_"^"_$G(PSGAT)
31 .. I $G(PSGP) S ST=$$ENQ^PSJORP2(PSGP,STRING) S:'ST ST=$S($D(PSGDLS):PSGDLS,1:$P(ND2,"^",2))
32 . S $P(PSJSYSW0,U,5)=2
33 G MWF:SCH["@",DONE:'TS&'MN
34 I 'TS S AM=MN*PSGDL,X=$$EN^PSGCT(ST,AM) G DONE
35 S TM=$E(ST_"00000",9,8+$L($P(TS,"-")))
36 F Q=1:1 Q:$P(TS,"-",Q)=""!(TM<$P(TS,"-",Q))
37 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
38 ;
39MWF ; if schedule is similar to monday-wednesday-friday
40 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
41SCHK 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
42 E Q
43 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
44 Q
45CHK F QQ=1:1:$L(SCH,"-") S WKD=$P(SCH,"-",QQ) I WKD=$E(X,1,$L(WKD)) D TS Q
46 Q
47TS F Q1=1:1:$L(TS,"-") S C=C+1 I C=PSGDL S X=X1_"."_$P(TS,"-",Q1) Q
48 Q
49 ;
50DONE ;
51 K %H,%T,%Y,MN,ND2,ND4,PSGDLS,PSGDL,Q1,QQ,SCH,TM,WKD,TS,X1,X2 Q
52 ;
53ADD ;
54 S X1=$P(X,"."),X2=$S(MN&'(MN#1440):MN\1440,1:1) D C^%DTC S Q=1 Q
55 ;
56ENPREV ; when "P" is enter at start date
57 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
58 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)
59 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)
60 W:'X !?17,"No other order found with this drug."
61 ;
62POUT ;
63 K:'X X K:Y PSGPDRG,PSGP,Q Q
64ENDL(SCH,DL) ;validate that dose limit should be allowed with this schedule
65 ;and that the dose limit is a whole number
66 I $G(SCH)="" Q 1
67 I ",ON CALL,ON-CALL,ONCALL,"[(","_SCH_",")!($$ONE^PSJBCMA(DFN,"",SCH)="O") W " Dose limit invalid with this schedule" Q 0
68 I DL'?1N.N W " Dose limit must be a whole number" Q 0
69 Q 1
Note: See TracBrowser for help on using the repository browser.