source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSULOG.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1PSOSULOG ;BHAM ISC/RTR-Log of prescriptions on suspense by day ; 11/18/92
2 ;;7.0;OUTPATIENT PHARMACY;**18,264**;DEC 1997;Build 19
3 I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) D WARN^PSOSUDCN Q
4 K ^TMP($J,"PSOSPLOG") N BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
5LOG W ! K DIR S DIR("A")="Sort by Patient Name or SSN",DIR(0)="SB^P:PATIENT NAME;S:SOCIAL SECURITY NUMBER",DIR("B")="PATIENT NAME"
6 S DIR("?")="Enter 'P' to sort by patient name, 'S' to sort by SSN, enter '^' to exit."
7 D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT S PSORT=Y
8DATE W ! K %DT S %DT="AEX",%DT("A")="Start Date: " D ^%DT K %DT G:Y=-1&(X'["^") DATE I X["^"!($D(DTOUT)) D MESS G EXIT
9EDATE W ! S BDATE=$E(Y,1,7) S %DT(0)=BDATE,%DT="AEX",%DT("A")="End Date: " D ^%DT K %DT G:Y=-1&(X'["^") EDATE I X["^"!($D(DTOUT)) D MESS G EXIT
10 S EDATE=$E(Y,1,7) W !
11 W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to see only those Rx's that have NOT yet been printed" D ^DIR K DIR D:$D(DIRUT) MESS G:Y["^"!($D(DIRUT)) EXIT S PSPRINT=$S(Y:1,1:0)
12 S PSOCNT=0 F PII=0:0 S PII=$O(^PS(59,PII)) Q:'PII S PSOCNT=PSOCNT+1
13 I PSOCNT=1 G SKIP
14 W !!?3,"You are logged in under the "_$P($G(^PS(59,+$G(PSOSITE),0)),"^")_" division.",!
15 K DIR S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Print only those Rx's suspended for this division",DIR("?")="Enter 'Yes' to print only those Rx's for this division, enter 'No' to print Rx's suspended for all divisions."
16 D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
17 S PSUSDIV=Y
18SKIP ;
19 I '$G(PSXSYS) G SKIPC
20 K DIR W ! S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want suspended CMOP Rx's included in this report" D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
21 I $G(Y) S PSOSCMOP=1
22SKIPC ;
23 W ! K DIR S DIR("A")="Do you want this report to print in 80 or 132 column format: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80" D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
24 W ! S PSORMZ=$S(Y=1:1,1:0)
25 K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP D MESS G EXIT
26 I $D(IO("Q")) S ZTRTN="REP^PSOSULOG",ZTDESC="Report is suspended Rx's" D G EXIT
27 .F GG="PSORMZ","PSOSITE","PSOPAR","PSORT","BDATE","EDATE","PSPRINT","PSUSDIV","PSOSCMOP" S:$D(@GG) ZTSAVE(GG)=""
28 .D ^%ZTLOAD W !,"Task queued to print"
29 G REP
30EXIT ;
31 K ^TMP($J,"PSOSPLOG") S:$D(ZTQUEUED) ZTREQ="@"
32 K BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOBAD,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORMZ,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
33 Q
34MESS W !!,"No report printed!",!! Q
35REP ;
36 K ^TMP($J,"PSOSPLOG")
37 U IO S $P(LINE,"-",$S($G(PSORMZ):130,1:79))=""
38 S BDATE=BDATE-.0001,QFLAG=0,PAGE=1
39 F ZZ=BDATE:0 S ZZ=$O(^PS(52.5,"C",ZZ)) Q:'ZZ!(ZZ>EDATE) F SIN=0:0 S SIN=$O(^PS(52.5,"C",ZZ,SIN)) Q:'SIN D
40 .Q:'$P($G(^PS(52.5,SIN,0)),"^",3)
41 .I $G(PSPRINT),$G(^PS(52.5,SIN,"P")) Q
42 .I '$G(PSOSCMOP),$P($G(^PS(52.5,SIN,0)),"^",7)'="" Q
43 .I $G(PSUSDIV),$G(PSOSITE)'=$P($G(^PS(52.5,SIN,0)),"^",6) Q
44 .S PAT=+$P($G(^PS(52.5,SIN,0)),"^",3) I $P($G(^DPT(PAT,0)),"^")="" Q
45 .I $P($G(^DPT(PAT,0)),"^",9)="",PSORT="S" Q
46 .S ^TMP($J,"PSOSPLOG",ZZ,$S(PSORT="P":$P(^DPT(PAT,0),"^"),1:$P(^DPT(PAT,0),"^",9)),SIN)=SIN
47 I $G(PSORMZ) G BIG
48 I '$D(^TMP($J,"PSOSPLOG")) D HEAD W !!,"NO RECORDS TO PRINT",! D:$E(IOST)="C" D ^%ZISC G EXIT
49 .K DIR S DIR(0)="E" D ^DIR K DIR
50 S HPAT="",HDAT=""
51 F PSODATE=0:0 S PSODATE=$O(^TMP($J,"PSOSPLOG",PSODATE)) Q:'PSODATE!($G(QFLAG)) S (Y,PDAT)=PSODATE D DD^%DT S PSODATEX=Y D HEAD S PAT="" F S PAT=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT)) Q:PAT=""!($G(QFLAG)) D
52 .F SINRX=0:0 S SINRX=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT,SINRX)) Q:'SINRX!($G(QFLAG)) D
53 ..S NODE=$G(^PS(52.5,SINRX,0)),PATPTR=+$P(NODE,"^",3)
54 ..I 'PATPTR Q
55 ..S PATNAME=$P($G(^DPT(PATPTR,0)),"^") Q:PATNAME=""
56 ..I $G(PSPRINT),$G(^PS(52.5,SINRX,"P")) Q
57 ..I $G(PSUSDIV),$G(PSOSITE)'=$P(NODE,"^",6) Q
58 ..I PAT'=HPAT!(HDAT'=PDAT) W !!?9,"Patient Name: "_$G(PATNAME) S HPAT=PAT,PDAT=HDAT
59 ..D:($Y+4)>IOSL HEAD Q:$G(QFLAG)
60 ..S PSOINRX=+$P($G(NODE),"^")
61 ..W !,$P($G(^PSRX(+$G(NODE),0)),"^")
62 ..W ?13,$P($G(^PSDRUG(+$P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^")
63 ..K PSOMW D
64 ...I $P(NODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(NODE),"P",$P(NODE,"^",5),0)),"^",2) Q
65 ...I $P(NODE,"^",13)!($O(^PSRX(+$G(NODE),1,0))) D Q
66 ....I $P(NODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(NODE),1,$P(NODE,"^",13),0)),"^",2) Q
67 ....F PP=0:0 S PP=$O(^PSRX(+$G(NODE),1,PP)) Q:'PP S PSOMW=$P($G(^PSRX(+$G(NODE),1,PP,0)),"^",2)
68 ...S PSOMW=$P($G(^PSRX(+$G(NODE),0)),"^",11)
69 ..W ?54,$G(PSOMW)
70 ..S PSOPRINT=$S($G(^PS(52.5,SINRX,"P")):"YES",1:"NO")
71 ..W ?56,PSOPRINT
72 ..I PSOPRINT="NO" S PSOBAD="" D CHKBAD I PSOBAD'="" W ?62,PSOBAD
73 ..I $G(PSOSCMOP),$P(NODE,"^",7)'="" D
74 ...W ?64,$S($P(NODE,"^",7)="Q":"QUEUED/TRANS",$P(NODE,"^",7)="X":"TRANS/COMPLETE",$P(NODE,"^",7)="L":"LOADING/TRANS",$P(NODE,"^",7)="P":"PRINTED/LOCAL",1:"")
75 I $E(IOST)'="P",'$G(QFLAG) W ! K DIR S DIR(0)="E" D ^DIR K DIR
76 W !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
77 W !,"** END OF REPORT **"
78 D ^%ZISC G EXIT
79HEAD ;
80 I $E(IOST)'="P",PAGE K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S QFLAG=1 Q
81 W @IOF W !?22,"RX SUSPENSE LIST "_$S($G(PSODATEX)'="":"FOR ",1:"")_$G(PSODATEX) W ?68,"PAGE: ",$G(PAGE) W !,"RX #",?13,"DRUG",?53,"MW",?56,"PRNT B/D/F",?66,$S($G(PSOSCMOP):"CMOP STATUS",1:"") W !,LINE S PAGE=PAGE+1
82 Q
83BIG ;
84 N PSOPRINT
85 I '$D(^TMP($J,"PSOSPLOG")) D HEADB W !!,"NO RECORDS TO PRINT",! D:$E(IOST)="C" D ^%ZISC G EXIT
86 .K DIR S DIR(0)="E" D ^DIR K DIR
87 F PSODATE=0:0 S PSODATE=$O(^TMP($J,"PSOSPLOG",PSODATE)) Q:'PSODATE!($G(QFLAG)) S Y=PSODATE D DD^%DT S PSODATEX=Y D:PAGE=1 HEADB D HEADND S PAT="" F S PAT=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT)) Q:PAT=""!($G(QFLAG)) D
88 .F SINRX=0:0 S SINRX=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT,SINRX)) Q:'SINRX!($G(QFLAG)) D
89 ..S NODE=$G(^PS(52.5,SINRX,0)),PATPTR=+$P(NODE,"^",3)
90 ..I 'PATPTR Q
91 ..S PATNAME=$P($G(^DPT(PATPTR,0)),"^") Q:PATNAME=""
92 ..I $G(PSPRINT),$G(^PS(52.5,SINRX,"P")) Q
93 ..I $G(PSUSDIV),$G(PSOSITE)'=$P(NODE,"^",6) Q
94 ..D:($Y+4)>IOSL HEADB Q:$G(QFLAG)
95 ..S PSOINRX=+$P($G(NODE),"^")
96 ..W !,$P($G(^PSRX(+$G(NODE),0)),"^")
97 ..W ?13,$G(PATNAME)
98 ..W ?45,$P($G(^PSDRUG(+$P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^")
99 ..K PSOMW D
100 ...I $P(NODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(NODE),"P",$P(NODE,"^",5),0)),"^",2) Q
101 ...I $P(NODE,"^",13)!($O(^PSRX(+$G(NODE),1,0))) D Q
102 ....I $P(NODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(NODE),1,$P(NODE,"^",13),0)),"^",2) Q
103 ....F PP=0:0 S PP=$O(^PSRX(+$G(NODE),1,PP)) Q:'PP S PSOMW=$P($G(^PSRX(+$G(NODE),1,PP,0)),"^",2)
104 ...S PSOMW=$P($G(^PSRX(+$G(NODE),0)),"^",11)
105 ..W ?88,$S($G(PSOMW)="W":"WINDOW",1:"MAIL")
106 ..S PSOPRINT=$S($G(^PS(52.5,SINRX,"P")):"YES",1:"NO")
107 ..W ?95,PSOPRINT
108 ..I PSOPRINT="NO" S PSOBAD="" D CHKBAD I PSOBAD'="" W ?103,PSOBAD
109 ..I $G(PSOSCMOP),$P(NODE,"^",7)'="" D
110 ...W ?104,$S($P(NODE,"^",7)="Q":"QUEUED FOR TRANSMISSION",$P(NODE,"^",7)="X":"TRANSMISSION COMPLETED",$P(NODE,"^",7)="L":"LOADING FOR TRANSMISSION",$P(NODE,"^",7)="P":"PRINTED LOCALLY",1:"")
111 I $E(IOST)'="P",'$G(QFLAG) W ! K DIR S DIR(0)="E" D ^DIR K DIR
112 W !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
113 W !,"** END OF REPORT **"
114 D ^%ZISC G EXIT
115HEADB ;
116 I $E(IOST)'="P",PAGE K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S QFLAG=1 Q
117 W @IOF
118 W !,"RX #",?13,"PATIENT",?45,"DRUG",?88,"TYPE",?93,"PRINTED B/D/F",?108,$S($G(PSOSCMOP):"CMOP STATUS",1:""),?122,"PAGE ",$G(PAGE) W !,LINE S PAGE=PAGE+1
119 Q
120HEADND W !!?40,"RX SUSPENSE LIST "_$S($G(PSODATEX)'="":"FOR ",1:"")_$G(PSODATEX)
121 Q
122 ;
123CHKADDR ;
124 N PSOBADR,PSOTEMP
125 S PSOBADR=$$BADADR^DGUTL3(PSODFN)
126 I PSOBADR D
127 .S PSOTEMP=$$CHKTEMP^PSOBAI(PSODFN)
128 I PSOBADR,'PSOTEMP S (PSOBAI,PSOBDF("B"))=1 Q
129 Q
130 ;
131FOREIGN ;
132 N PSOFORGN,DFN
133 S DFN=PSODFN D ADD^VADPT
134 S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOBDF("F")=1
135 Q
136 ;
137CHKMAIL ;
138 N PSOTEMP,MAILEXP
139 S PSOTEMP=$G(^PS(55,PSODFN,0)) Q:$P(PSOTEMP,"^",3)'=2
140 S MAILEXP=$P(PSOTEMP,"^",5) I MAILEXP=""!(MAILEXP>DT) S PSOBDF("D")=1
141 Q
142 ;
143CHKBAD ;
144 K PSOBDF
145 S PSODFN=PATPTR
146 D CHKADDR I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
147 D CHKMAIL I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
148 D FOREIGN I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
149 Q
150 ; CHANGE TO USE FOLLOWING IF WANT TO SEE WHY RX'S DID NOT PRINT PREVIOUSLY (INSTEAD OF CURRENT BAD STATUS)
151 N RX,SEQ,FILL,ZZ
152 S RX=+$G(NODE),FILL=$P(NODE,"^",13)
153 S SEQ=0 F S SEQ=$O(^PSRX(RX,"A",SEQ)) Q:'SEQ S X=$G(^PSRX(RX,"A",SEQ,0)) D
154 .I $P(X,"^",2)="S" S ZZ=$P(X,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=FILL,X["due to" D
155 ..I X["DO NOT MAIL" S PSOBAD="D" Q
156 ..I X["BAD ADDRESS" S PSOBAD="B" Q
157 ..I X["FOREIGN ADDRESS" S PSOBAD="F" Q
158 Q
159 ;
Note: See TracBrowser for help on using the repository browser.