source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIG.m@ 1501

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1PSOSIG ;BIR/RTR-Utility to create SIG ;6/04/00
2 ;;7.0;OUTPATIENT PHARMACY;**46,99,114**;DEC 1997
3 ;External reference to PS(51 supported by DBIA 2224
4 ;External reference to PS(51.1 supported by DBIA 2225
5 ;External reference to PSDRUG( supported by DBIA 221
6 ;
7EN(PSOSIGX) ;
8 N VARIABLE
9 Q
10SCH ;SCH = schedule entered SCHEX = expanded schedule
11 N SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST
12 K SCHEX S SQFLAG=0
13 I $G(SCH)="" S SCHEX="" Q
14 I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
15 N PSOSCUP S SCH=$$UPPER(SCH)
16 F SCLOOP=0:0 S SCLOOP=$O(^PS(51.1,"B",SCH,SCLOOP)) Q:'SCLOOP!(SQFLAG) I $P($G(^PS(51.1,SCLOOP,0)),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SQFLAG=1
17 Q:SQFLAG
18 I $P($G(^PS(51,"A",SCH)),"^")'="" S SCHEX=$P(^(SCH),"^") Q
19 S SCLOOP=0 F SCLP=1:1:$L(SCH) S SCLPS=$E(SCH,SCLP) I SCLPS=" " S SCLOOP=SCLOOP+1
20 I SCLOOP=0 S SCHEX=SCH Q
21 S SCLOOP=SCLOOP+1
22 K SCLHOLD F SCIN=1:1:SCLOOP S (SODL,SCLHOLD(SCIN))=$P(SCH," ",SCIN) D
23 .Q:$G(SODL)=""
24 .S SQFLAG=0 F SST=0:0 S SST=$O(^PS(51.1,"B",SODL,SST)) Q:'SST!($G(SQFLAG)) I $P($G(^PS(51.1,SST,0)),"^",8)'="" S SCLHOLD(SCIN)=$P($G(^(0)),"^",8),SQFLAG=1
25 .Q:$G(SQFLAG)
26 .I $P($G(^PS(51,"A",SODL)),"^")'="" S SCLHOLD(SCIN)=$P(^(SODL),"^")
27 S SCHEX="",SQFLAG=0 F SST=1:1:SCLOOP S SCHEX=SCHEX_$S($G(SQFLAG):" ",1:"")_$G(SCLHOLD(SST)),SQFLAG=1
28 Q
29QTY(PSOQX) ;
30 N QDOSE
31 K PSOQX("QTY")
32 N PSOQTYQT,PSOLPSD I $G(PSOFDR) S PSOQTYQT=0 D I $G(PSOQTYQT) Q
33 .I $G(PSODRUG("IEN")),$D(^PSDRUG(+$G(PSODRUG("IEN")),0)) D I PSOQTYQT Q
34 ..I $P(^PSDRUG(PSODRUG("IEN"),0),"^",3)[2!($P(^(0),"^",3)[3)!($P(^(0),"^",3)[4)!($P(^(0),"^",3)[5) S PSOQTYQT=1
35 .S PSOLPSD="" F S PSOLPSD=$O(PSONEW("SCHEDULE",PSOLPSD)) Q:PSOLPSD=""!(PSOQTYQT) I $G(PSONEW("SCHEDULE",PSOLPSD))["PRN"!($G(PSONEW("SCHEDULE",PSOLPSD))["prn") S PSOQTYQT=1 Q
36 N PSOOUTQT S PSOOUTQT=1
37QTYCP ;CPRS qty call comes through here
38 N PSQQUIT,QTSH,PSQ,PSQMIN,PSQMINZ,PSOQRND,PSOLOWER,PSOLOWX,PSOLOWXL,PSOLOWST
39 K PSOFRQ S PSQQUIT=0
40 I '$G(PSOCPRQT) S QDOSE=0 F PSQ=0:0 S PSQ=$O(PSOQX("DOSE",PSQ)) Q:'PSQ S QDOSE=PSQ S:'$G(PSOQX("DOSE ORDERED",PSQ)) PSQQUIT=1
41 ;Q:PSQQUIT!('QDOSE)
42 I '$G(PSOCPRQT) Q:PSQQUIT
43 Q:'$G(PSOQX("DAYS SUPPLY"))
44 Q:'$G(QDOSE)
45 G:QDOSE>1 COMP
46 Q:'$G(PSOQX("DOSE ORDERED",1))
47 Q:'$G(PSOQX("DAYS SUPPLY"))&('$G(PSOQX("DURATION",1)))
48 S PSOLOWER=0
49 I $G(PSOQX("DURATION",1)) D
50 .S PSOLOWX=$L(PSOQX("DURATION",1))
51 .S PSOLOWXL=$S($E(PSOQX("DURATION",1),PSOLOWX)="M":1,$E(PSOQX("DURATION",1),PSOLOWX)="H":60,$E(PSOQX("DURATION",1),PSOLOWX)="S":.01666,$E(PSOQX("DURATION",1),PSOLOWX)="W":10080,$E(PSOQX("DURATION",1),PSOLOWX)="L":43200,1:1440)
52 .S PSOLOWER=PSOLOWXL*(+$G(PSOQX("DURATION",1)))
53 S PSOLOWX=0 I +$G(PSOQX("DAYS SUPPLY")) S PSOLOWX=1440*+$G(PSOQX("DAYS SUPPLY"))
54 Q:'$G(PSOLOWER)&('$G(PSOLOWX))
55 S QTSH=$G(PSOQX("SCHEDULE",1)) D QTS Q:PSQQUIT!('$G(PSOFRQ))
56 S PSOLOWST=$S('$G(PSOLOWER):$G(PSOLOWX),'$G(PSOLOWX):$G(PSOLOWER),$G(PSOLOWER)>$G(PSOLOWX):$G(PSOLOWX),$G(PSOLOWX)>$G(PSOLOWER):$G(PSOLOWER),$G(PSOLOWX)=$G(PSOLOWER):$G(PSOLOWER),1:0)
57 Q:'$G(PSOLOWST)
58 S PSQMIN=+$G(PSOLOWST)
59 S PSQMINZ=PSQMIN/PSOFRQ
60 S PSOQRND=PSQMINZ*+$G(PSOQX("DOSE ORDERED",1)) Q:'PSOQRND
61 D ROUND G QEND
62 Q
63COMP ;COMPLEX DOSE HERE
64 N PSOQEXC,PSOQAND,PSOQTHEN,PSQL,PSQMNL,PSQMNLX,PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSQ1,PSODUX,PSODUXX,PSODSMIN
65 ;PSODUTOT = TOTAL OF ALL DURATIONS
66 ;PSODUDIF = DIFF. OF DURATION VS DAYS SUPPLY
67 ;PSODUMIS = # OF SEQUENCES MISSING A DURATION IF >1 CAN'T DEFAULT
68 ;PSODUREP = SEQUENCE # THAT IS MISSING DURATION
69 ;PSODSMIN = MINUTES OF DAYS SUPPLY
70 S (PSODUTOT,PSODUDIF,PSODUMIS,PSODUREP,PSODSMIN,PSOQAND,PSOQTHEN,PSOQEXC)=0
71 F PSQL=1:1:QDOSE S:$G(PSOQX("CONJUNCTION",PSQL))["A" PSOQAND=1 S:$G(PSOQX("CONJUNCTION",PSQL))["T" PSOQTHEN=1 S:$G(PSOQX("CONJUNCTION",PSQL))["X" PSOQEXC=1
72 I $G(PSOQEXC) G QEND
73 I $G(PSOQAND) G COMP^PSOSIGCX
74 F PSQ1=1:1:QDOSE D Q:PSODUMIS>1
75 .I '$G(PSOQX("DURATION",PSQ1)) S PSODUMIS=PSODUMIS+1,PSODUREP=PSQ1 Q
76 .S PSODUX=$L(PSOQX("DURATION",PSQ1))
77 .S PSODUXX=$S($E(PSOQX("DURATION",PSQ1),PSODUX)="M":1,$E(PSOQX("DURATION",PSQ1),PSODUX)="H":60,$E(PSOQX("DURATION",PSQ1),PSODUX)="S":.01666,$E(PSOQX("DURATION",PSQ1),PSODUX)="W":10080,$E(PSOQX("DURATION",PSQ1),PSODUX)="L":43200,1:1440)
78 .S PSODUTOT=PSODUTOT+(PSODUXX*(+$G(PSOQX("DURATION",PSQ1))))
79 G:PSODUMIS>1 QEND ; More than 1 sequence missing a duration
80 I $G(PSODUMIS),'$G(PSOQX("DAYS SUPPLY")) G QEND ; missing 1 duration, no days supply
81 S PSODSMIN=1440*+$G(PSOQX("DAYS SUPPLY"))
82 I $G(PSODSMIN),$G(PSODSMIN)<$G(PSODUTOT) G QEND
83 I '$G(PSODUMIS),$G(PSODSMIN),$G(PSODUTOT)>$G(PSODSMIN) G QEND ; no missing durations, but total durations are greater than days supply
84 I $G(PSODUMIS),$G(PSODSMIN),$G(PSODSMIN)'>$G(PSODUTOT) G QEND ; 1 missing duration, and total of other durations are not less than days supply
85 I '$G(PSODSMIN),$G(PSODUMIS) G QEND ; no days supply, missing a duration
86 I $G(PSODUREP) S PSODUDIF=$G(PSODSMIN)-$G(PSODUTOT)
87 F PSQ=1:1:QDOSE D Q:$G(PSQQUIT)
88 .I '$G(PSOQX("DOSE ORDERED",PSQ))!($G(PSOQX("SCHEDULE",PSQ))="") S PSQQUIT=1 Q
89 .S QTSH=$G(PSOQX("SCHEDULE",PSQ)) D QTS S:'$G(PSOFRQ) PSQQUIT=1 Q:$G(PSQQUIT)
90 .I $G(PSOQX("DURATION",PSQ)) S PSQMNL=$L(PSOQX("DURATION",PSQ)) D
91 ..S PSQMNLX=$S($E(PSOQX("DURATION",PSQ),PSQMNL)="M":1,$E(PSOQX("DURATION",PSQ),PSQMNL)="H":60,$E(PSOQX("DURATION",PSQ),PSQMNL)="S":.01666,$E(PSOQX("DURATION",PSQ),PSQMNL)="W":10080,$E(PSOQX("DURATION",PSQ),PSQMNL)="L":43200,1:1440)
92 ..S PSQMIN=PSQMNLX*(+$G(PSOQX("DURATION",PSQ)))
93 .I '$G(PSOQX("DURATION",PSQ)) S PSQMIN=$G(PSODUDIF)
94 .S PSQMINZ=PSQMIN/PSOFRQ
95 .S PSOQRND=$S('$G(PSOQRND):PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ)),1:$G(PSOQRND)+(PSQMINZ*+$G(PSOQX("DOSE ORDERED",PSQ))))
96 I $G(PSQQUIT) G QEND
97 I $G(PSOQRND) D ROUND
98 G QEND
99QTS ;Find frequency
100 ;QTSH = SHCEDULE
101 ;either return PSOFRQ for frequency or PSSQUIT for no frequency
102 N SQTFLAG,SQQT,ZZQT,ZZQ,ZZQQ,ZQHOLD,QGLFLAG,PZQT,ZDL,ZZQX
103 K PSOFRQ
104 S (QGLFLAG,ZZQX)=0
105 I $G(QTSH)="" S PSQQUIT=1 Q
106 S SQTFLAG=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG)) I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),SQTFLAG=1
107 Q:SQTFLAG
108 F SQQT=0:0 S SQQT=$O(^PS(51,"B",QTSH,SQQT)) Q:'SQQT!($G(SQTFLAG)) I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),SQTFLAG=1
109 Q:SQTFLAG
110 S ZZQT=0 F ZZQ=1:1:$L(QTSH) S ZZQQ=$E(QTSH,ZZQ) I ZZQQ=" " S ZZQT=ZZQT+1
111 I 'ZZQT S PSQQUIT=1 Q
112 S ZZQT=ZZQT+1
113 K ZQHOLD S QGLFLAG=0 F PZQT=1:1:ZZQT S (ZDL,ZQHOLD)=$P(QTSH," ",PZQT) D
114 .Q:$G(ZDL)=""
115 .S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51.1,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX)) I $P($G(^PS(51.1,SQQT,0)),"^",3) S PSOFRQ=$P($G(^(0)),"^",3),ZZQX=1,QGLFLAG=QGLFLAG+1
116 .Q:ZZQX
117 .S ZZQX=0 F SQQT=0:0 S SQQT=$O(^PS(51,"B",ZDL,SQQT)) Q:'SQQT!($G(ZZQX)) I $P($G(^PS(51,SQQT,0)),"^",8) S PSOFRQ=$P($G(^(0)),"^",8),ZZQX=1,QGLFLAG=QGLFLAG+1
118 I $G(QGLFLAG)>1 K PSOFRQ
119 I '$G(PSOFRQ) S PSQQUIT=1
120 Q
121QEND ;
122 K PSOFRQ
123 I $G(PSOOUTQT),$G(QTYHLD),$G(PSOQX("QTY")),$G(QTYHLD)'=$G(PSOQX("QTY")) N DIR W !!!,"Quantity has been changed from "_QTYHLD_" to "_PSOQX("QTY") W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR W ! K DIR
124 Q
125ROUND ;
126 Q:'$G(PSOQRND)
127 I PSOQRND'["." S PSOQX("QTY")=PSOQRND Q
128 S PSOQX("QTY")=$P(PSOQRND,".")+1
129 Q
130DAY(DATE) ;First 5 digits of FileMan date
131 N X
132 I DATE'?5N Q -1
133 S X=$E(DATE,4,5) I X<1!(X>12) Q -1
134 S X=DATE+1+(X=12*88)_"01"
135 Q $E($$FMADD^XLFDT(X,-1),6,7)
136 ;
137QTYX(PSOQX) ;
138 N PSOQLP,PSOQLN,PSOQAR,PSOCPRQT,QDOSE,QDOSEX S PSOCPRQT=1 F PSOQLP=0:0 S PSOQLP=$O(PSOQX("DURATION",PSOQLP)) Q:'PSOQLP D
139 .S PSOQAR("DURATION",PSOQLP)=$G(PSOQX("DURATION",PSOQLP))
140 .I $E(PSOQX("DURATION",PSOQLP))?1A S PSOQLN=$L(PSOQX("DURATION",PSOQLP)) S PSOQX("DURATION",PSOQLP)=$E(PSOQX("DURATION",PSOQLP),2,PSOQLN)_$E(PSOQX("DURATION",PSOQLP))
141 S QDOSE=0 F QDOSEX=0:0 S QDOSEX=$O(PSOQX("DOSE ORDERED",QDOSEX)) Q:'QDOSEX S QDOSE=QDOSE+1
142 I '$G(PSOQX("QTY")) D QTYCP G QPASS
143 D QTYCP^PSOSIGDS
144QPASS F PSOQLP=0:0 S PSOQLP=$O(PSOQAR("DURATION",PSOQLP)) Q:'PSOQLP D
145 .S PSOQX("DURATION",PSOQLP)=$G(PSOQAR("DURATION",PSOQLP))
146 K PSOCPRQT
147 Q
148DAYS(PSOQX) ;Entry point for Days Supply calc for PSO
149 ;Kill days supply here
150 Q:'$G(PSOQX("QTY"))
151 D QTYOPS^PSOSIGDS
152 Q
153 ;
154UPPER(PSOSCUP) ;
155 Q $TR(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.