source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCRP.m@ 1452

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1PSOTPCRP ;BIR/RTR-Non VA phycisian eligible patient report ;07/07/03
2 ;;7.0;OUTPATIENT PHARMACY;**145,153,227**;DEC 1997
3 Q ;placed out of order by patch PSO*7*227
4EN ;
5 W !!,"This report prints entries from the TPB ELIGIBILITY file (#52.91)."
6 W !,"If multiple Institutions are selected, and some Institutions have data and",!,"some don't, only those Institutions that have data will print on the report.",!
7 N PSOGPINS,PSOGPAR,PSOGOK,PSOGSORT
8 S PSOGPINS=0
9INST ;Ask for Institutions
10 K DIR S DIR(0)="S^S:SELECT;A:ALL",DIR("B")="SELECT",DIR("A")="Print Report for Selected Institutions, or All Institutions" D D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! Q
11 .S DIR("?")=" ",DIR("?",1)="Enter 'S' to select one or more Institutions to print the report for,",DIR("?",2)="Enter 'A' to print the report for all Institutions."
12 I Y="A" S PSOGPINS=1 G PASS
13 S PSOGOK=0
14INSTX ;Ask for individual Institutions
15 K DIC S DIC(0)="QEAMZ",DIC=4 D W ! D ^DIC K DIC I 'PSOGOK,(Y<1!($D(DUOUT))!($D(DTOUT))) W !!,"Nothing queued to print.",! Q
16 .I 'PSOGOK,$G(DUZ(2)) S DIC("B")=DUZ(2)
17 .I PSOGOK S DIC("A")="Select another INSTITUTION NAME:"
18 I Y>0 S PSOGPAR(+Y)="",PSOGOK=1 G INSTX
19 I '$O(PSOGPAR(0)) W !,"No Institutions selected, nothing queued to print.",! Q
20PASS ;
21ACT ;Ask for type of report
22 W ! K DIR S DIR(0)="S^A:ALL PATIENTS;E:ELIGIBLE PATIENTS;I:INELIGIBLE PATIENTS",DIR("B")="ALL PATIENTS",DIR("A")="Select patients for report" D D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! Q
23 .S DIR("?")=" ",DIR("?",1)="To see only those patients currently eligible for the Transitional Pharmacy",DIR("?",2)="Benefit program, enter 'E'. To see all patients currently in the TPB"
24 .S DIR("?",3)="ELIGIBILITY file (#52.91), but not currently eligible for the benefit,",DIR("?",4)="enter 'I'. To see all patients in the TPB ELIGIBILITY file (#52.91),"
25 .S DIR("?",5)="both eligible and ineligible, enter 'A'."
26 S PSOGSORT=Y
27 W ! K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! Q
28 I $D(IO("Q")) S ZTRTN="START^PSOTPCRP",ZTDESC="TPB ELIGIBILITY Report",ZTSAVE("PSOGPINS")="",ZTSAVE("PSOGSORT")="",ZTSAVE("PSOGPAR(")="" D ^%ZTLOAD K %ZIS W !,"Report queued to print.",! K ZTRTN,ZTDESC,ZTSAVE Q
29START ;
30 K ^TMP("PSOGP",$J)
31 U IO
32 N DIC,DIQ,DA,DR,PSOGPOUT,PSOGDV,PSOGPAGE,PSOGTOP,PSOGPLIN,PSOGLOP,PSOGNODE,PSOGNAME,PSOINAME,PSOTAR,PSOG1,PSOG2,PSOG3,PSOG4,DFN,VADM,PSOGSSN,PSOGSSNX,PSOXND,PSOXRS,VA,VAERR,PSOTINS,PSOTARX,PSOVADIS,PSOVADIX
33 I '$G(DT) S DT=$$DT^XLFDT
34 S PSOGPOUT=0,PSOGDV=$S($E(IOST,1,2)'="C-":0,1:1),PSOGPAGE=1
35 S $P(PSOGPLIN,"-",79)=""
36 ;Set TMP global, store grand total count in PSOGTOP, Subtotals in PSOTAR array
37 S PSOGTOP=0
38 F PSOGLOP=0:0 S PSOGLOP=$O(^PS(52.91,PSOGLOP)) Q:'PSOGLOP D
39 .S PSOGNODE=$G(^PS(52.91,PSOGLOP,0)) I 'PSOGNODE Q
40 .;If selecting institutions, and patient if file with no Institution won't show on the report??
41 .I 'PSOGPINS,'$D(PSOGPAR(+$P(PSOGNODE,"^",8))),$P(PSOGNODE,"^",8) Q
42 .I PSOGSORT="E",$P(PSOGNODE,"^",3),$P(PSOGNODE,"^",3)'>DT Q
43 .I PSOGSORT="I" I '$P(PSOGNODE,"^",3)!($P(PSOGNODE,"^",3)>DT) Q
44 .K VADM S DFN=+$P(PSOGNODE,"^") I 'DFN Q
45 .D DEM^VADPT I $G(VADM(1))="" K VADM Q
46 .S PSOGNAME=$G(VADM(1))
47 .K VADM
48 .K VA,VAERR S DFN=+$P(PSOGNODE,"^") D PID^VADPT6
49 .S PSOGNAME=PSOGNAME_"("_$G(VA("BID"))_")"
50 .K VA,VAERR
51 .S ^TMP("PSOGP",$J,$S($P(PSOGNODE,"^",8):$P(PSOGNODE,"^",8),1:"NONE"),PSOGNAME,$P(PSOGNODE,"^"),PSOGLOP)="",PSOGTOP=PSOGTOP+1
52 .I $P(PSOGNODE,"^",8) S PSOTAR($P(PSOGNODE,"^",8))=$G(PSOTAR($P(PSOGNODE,"^",8)))+1 Q
53 .S PSOTAR("NONE")=$G(PSOTAR("NONE"))+1
54 ;D HD
55 I 'PSOGTOP D HD W !!,"No patients found that meet report criteria.",! G END
56 S PSOG1="" F S PSOG1=$O(^TMP("PSOGP",$J,PSOG1)) Q:PSOG1=""!(PSOGPOUT) D
57 .I $G(PSOG1)="NONE" S PSOINAME="NONE"
58 .I $G(PSOG1)'="NONE" K PSOTINS,DIC,DIQ,DA,DR S DIC=4,DR=".01",DA=+PSOG1,DIQ(0)="E",DIQ="PSOTINS" D EN^DIQ1 S PSOINAME=$G(PSOTINS(4,+PSOG1,.01,"E")) K DIC,DIQ,DR,DA,PSOTINS
59 .D HD I PSOGPOUT Q
60 .S PSOTARX=0
61 .S PSOG2="" F S PSOG2=$O(^TMP("PSOGP",$J,PSOG1,PSOG2)) Q:PSOG2=""!(PSOGPOUT) F PSOG3=0:0 S PSOG3=$O(^TMP("PSOGP",$J,PSOG1,PSOG2,PSOG3)) Q:'PSOG3!(PSOGPOUT) D
62 ..F PSOG4=0:0 S PSOG4=$O(^TMP("PSOGP",$J,PSOG1,PSOG2,PSOG3,PSOG4)) Q:'PSOG4!(PSOGPOUT) D
63 ...S PSOXND=$G(^PS(52.91,PSOG4,0))
64 ...D ADDR
65 ...S PSOTARX=PSOTARX+1
66 ...W !!,PSOG2
67 ...W ?38,$S($P(PSOXND,"^",2):$E($P(PSOXND,"^",2),4,5)_"/"_$E($P(PSOXND,"^",2),6,7)_"/"_$E($P(PSOXND,"^",2),2,3),1:"")
68 ...W ?47,$S($P(PSOXND,"^",3):$E($P(PSOXND,"^",3),4,5)_"/"_$E($P(PSOXND,"^",3),6,7)_"/"_$E($P(PSOXND,"^",3),2,3),1:"")
69 ...W ?56,$S($P(PSOXND,"^",12):$E($P(PSOXND,"^",12),4,5)_"/"_$E($P(PSOXND,"^",12),6,7)_"/"_$E($P(PSOXND,"^",12),2,3),1:"")
70 ...S PSOXRS=$P(PSOXND,"^",4)
71 ...W ?65,$S(PSOXRS=1:"VA Provider",PSOXRS=2:"No/Show/Cancel",PSOXRS=3:"Patient Ended",PSOXRS=4:"N/F Rx",PSOXRS=5:"Patient Expired",PSOXRS=6:"Rx's Inactive",PSOXRS=7:"Exclusion",PSOXRS=8:"Refused Appt.",PSOXRS=9:"Pat Unreachable",1:"")
72 ...I $P(PSOXND,"^",9) D
73 ....I $P(PSOXND,"^",9)=1 W !?1,"Exclusion: ACTIVE RX "_$P(PSOXND,"^",11) Q
74 ....I $P(PSOXND,"^",9)=2 W !?1,"Exclusion: ACTUAL APPT. <30 DAYS FROM DATE APPT. MADE" Q
75 ....I $P(PSOXND,"^",9)=3 W !?1,"Exclusion: ACTIVE RX "_$P(PSOXND,"^",11)_" & ACTUAL APPT. <30 DAYS FROM DATE APPT. MADE"
76 ...I ($Y+6)>IOSL,$G(PSOVADIS)'="" D HD I PSOGPOUT K PSOVADIS,PSOVADIX Q
77 ...I $G(PSOVADIS)'="" W !,$G(PSOVADIS)
78 ...I ($Y+6)>IOSL,$G(PSOVADIX)'="" D HD I PSOGPOUT K PSOVADIS,PSOVADIX Q
79 ...I $G(PSOVADIX)'="" W !,$G(PSOVADIX)
80 ...K PSOVADIS,PSOVADIX
81 ...I ($Y+6)>IOSL,PSOTARX'=$G(PSOTAR(PSOG1)) D HD
82 G END
83HD ;HEADER
84 I PSOGDV,PSOGPAGE'=1 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSOGPOUT=1 Q
85 I PSOGPAGE=1,'PSOGDV W ! I 1
86 E W @IOF
87 W !,$S(PSOGSORT="E":"Eligible Patients",PSOGSORT="I":"Ineligible Patients",1:"All Patients")_$S($G(PSOINAME)="":"",1:" (")_$G(PSOINAME)_$S($G(PSOINAME)="":"",1:")")_" Total: "_$S($G(PSOG1)'="":$G(PSOTAR(PSOG1)),1:""),?68,"PAGE: "_PSOGPAGE
88 S PSOGPAGE=PSOGPAGE+1
89 ;I $G(PSOINAME)'="" W !,"("_PSOINAME_")"_" Total: ",$G(PSOTAR(PSOG1))
90 W !,"Grand Total: "_PSOGTOP,?38,"Start",?47,"Stop",?56,"Letter",?65,"Inactivation",!,"Patient",?38,"Date",?47,"Date",?56,"Date",?65,"Reason",!,PSOGPLIN
91 Q
92END ;End report
93 K ^TMP("PSOGP",$J),PSOGPAR,PSOGSORT,PSOGPINS
94 I '$G(PSOGPOUT),PSOGDV W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
95 I 'PSOGDV W !!,"End of Report."
96 I PSOGDV W !
97 E W @IOF
98 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
99 Q
100ADDR ;Check for difference in State
101 N PSOVA1,PSOVA2,VAPA
102 S (PSOVADIX,PSOVADIS)=""
103 S DFN=$P($G(^PS(52.91,PSOG4,0)),"^")
104 I '$G(DFN) Q
105 D ADD^VADPT
106 I '$G(VAPA(12)) K VAPA G ADDRX
107 I $P($G(VAPA(22,1)),"^",3)'="Y",$P($G(VAPA(22,2)),"^",3)'="Y",$P($G(VAPA(22,5)),"^",3)'="Y" K VAPA G ADDRX
108 S PSOVADIS="Confidential State = "_$P($G(VAPA(17)),"^",2)
109 I $G(VAPA(5))'=$G(VAPA(17)) S PSOVADIX=$S($G(VAPA(9)):"Temporary State = ",1:"Permanent State = ")_$P($G(VAPA(5)),"^",2)
110 K VAPA
111 Q
112ADDRX ;
113 K VAPA D ADD^VADPT I '$G(VAPA(9)) S PSOVADIS="Permanent State = "_$P($G(VAPA(5)),"^",2) K VAPA Q
114 S PSOVADIS="Temporary State = "_$P($G(VAPA(5)),"^",2)
115 S PSOVA1=$G(VAPA(5))
116 K VAPA S VAPA("P")="" D ADD^VADPT
117 S PSOVA2=$G(VAPA(5))
118 I PSOVA1=PSOVA2 K VAPA Q
119 S PSOVADIX="Permanent State = "_$P($G(PSOVA2),"^",2)
120 K VAPA
121 Q
Note: See TracBrowser for help on using the repository browser.