source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCRX.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1PSOTPCRX ;BIR/RTR-Enrollment and Active Rx check ;08/01/03
2 ;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
3 ;External reference to PS(55 supported by DBIA 2228
4 ;External reference to PSDRUG( supported by DBIA 221
5 ;External reference to XTMP("SDPSO145" supported by DBIA's 4193,4194
6 ;External references to DGENA supported by DBIA 3812
7 ;External reference to DGENA4 supported by DBIA 4192
8 ;
9 ;Enrollment check for TPC Eligibility
10ENR(PSOENPAT,PSOENRDT) ;;If not enrolled, Patient does not go in file
11 I '$G(PSOENPAT) Q 0
12 S:'$G(PSOENRDT) PSOENRDT=$$DT^XLFDT
13 N PSODGENR,PSODDONE,PSODRIEN,PSODGRDT
14 S PSODRIEN=$$FINDCUR^DGENA(PSOENPAT),PSODDONE=0
15 Q:'PSODRIEN 0
16 F Q:PSODDONE D
17 .I '$$GET^DGENA(PSODRIEN,.PSODGENR) S PSODDONE=-1 Q
18 .S PSODGRDT=$G(PSODGENR("APP")) S:PSODGRDT="" PSODGRDT=$G(PSODGENR("DATE"))
19 .I PSODGRDT,PSODGRDT<PSOENRDT S PSODDONE=1 S:$$CATEGORY^DGENA4(PSOENPAT,$G(PSODGENR("STATUS")))="N" PSODDONE=-1 Q
20 .S PSODRIEN=$$FINDPRI^DGENA(PSODRIEN)
21 .I 'PSODRIEN S PSODDONE=-1 Q
22 .K PSODGENR
23 Q $S(PSODDONE<1:0,1:1)
24 Q
25 ;Active Rx check for eligibility
26RX(PSOTRXPT) ;
27 I '$G(PSOTRXPT) Q 0
28 N PSOTRXDT,PSOTRXDG,PSOTRX,PSOTRX1,PSOTRX2,X,X1,X2
29 S PSOTRX=0
30 ;Using Oct 22 minus 485 days
31 S X1=3031022,X2=-486 D C^%DTC S PSOTRXDT=X K X,X1,X2
32 F PSOTRX1=PSOTRXDT:0 S PSOTRX1=$O(^PS(55,PSOTRXPT,"P","A",PSOTRX1)) Q:'PSOTRX1!(PSOTRX) S PSOTRX2="" F S PSOTRX2=$O(^PS(55,PSOTRXPT,"P","A",PSOTRX1,PSOTRX2)) Q:PSOTRX2=""!(PSOTRX) D
33 .I $P($G(^PSRX(PSOTRX2,0)),"^",2)=PSOTRXPT,$P($G(^(0)),"^")'="",$P($G(^("STA")),"^")'="",$P($G(^("STA")),"^")'=13 D
34 ..I $P($G(^PSRX(PSOTRX2,0)),"^",13),$P($G(^(0)),"^",13)<PSOTRXDT Q
35 ..S PSOTRXDG=$P($G(^PSRX(PSOTRX2,0)),"^",6)
36 ..I PSOTRXDG,$P($G(^PSDRUG(PSOTRXDG,0)),"^",3)'["S",$P($G(^(0)),"^",3)'["I" S PSOTRX=1 S ^XTMP("SDPSO145","ACRX",PSOTRXPT)=$P($G(^PSRX(PSOTRX2,0)),"^")
37 Q PSOTRX
38SCH ;
39 I '$D(^XTMP("SDPSO145","PAT","S")) Q
40 ;Scheduling
41 N PSOWAITT,PSOTPDRD,PSOACIRX,PSOXLP1,PSOXLP2,PSOXLP3,PSOXLESS,PSOTX1,PSOTX2,PSOTX3,PSOLXQT,PSOXNRLD,PSOXTCRX
42 S PSOTX1="" F S PSOTX1=$O(^XTMP("SDPSO145","PAT","S",PSOTX1)) Q:PSOTX1="" D
43 .S PSOXLESS=0 S PSOXLP1="" F S PSOXLP1=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1)) Q:PSOXLP1=""!(PSOXLESS) S PSOXLP2="" F S PSOXLP2=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2)) Q:PSOXLP2=""!(PSOXLESS) D
44 ..I $G(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2)) S PSOXLESS=1
45 .S PSOLXQT=0
46 .S PSOTX2="" F S PSOTX2=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2)) Q:PSOTX2=""!(PSOLXQT) S PSOTX3="" F S PSOTX3=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3)) Q:PSOTX3=""!(PSOLXQT) D
47 ..S PSOTPDRD=$P($G(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3)),"^",3)
48 ..S PSOXNRLD=1 S:'$D(^XTMP("SDPSO145","NOTEN",PSOTX1)) PSOXNRLD=$$ENR(PSOTX1,3030725) I $D(^XTMP("SDPSO145","NOTEN",PSOTX1))!('$G(PSOXNRLD)) D Q
49 ...S ^XTMP("SDPSO145","NOTEN",PSOTX1)="",PSOLXQT=1
50 ..S PSOXTCRX=0 S:'$D(^XTMP("SDPSO145","ACRX",PSOTX1)) PSOXTCRX=$$RX(PSOTX1) I PSOXTCRX!($D(^XTMP("SDPSO145","ACRX",PSOTX1))) D Q
51 ...S PSOACIRX=$G(^XTMP("SDPSO145","ACRX",PSOTX1))
52 ...;S PSOLXQT=1
53 ...I $D(^PS(52.91,PSOTX1,0)) D K PSOACIRX Q
54 ....D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
55 ....I $D(^XTMP("SDPSO145","PAT","E",PSOTX1)) K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="5////"_"X" D ^DIE K DA,DR,DIE
56 ...D SNM
57 ...I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)" K PSOTPSNM K PSOACIRX Q
58 ...S PSOWAITT=$S($D(^XTMP("SDPSO145","PAT","E",PSOTX1)):"X",1:"S")
59 ...K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTX1,DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";4////"_PSOTPDRD_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3_";8////"_$S($G(PSOXLESS):3,1:1)_";10////"_$G(PSOACIRX) D
60 ....S DIC("DR")=DIC("DR")_";5////"_PSOWAITT K DD,DO D FILE^DICN
61 ....K PSOWAITT,PSOTPSNM,PSOACIRX,DO,DD,DIC,DIE,X,DINUM
62 ....I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exlusion)" Q
63 ....S PSOITOT=$G(PSOITOT)+1
64 ..I PSOXLESS D Q
65 ...;S PSOLXQT=1
66 ...I $D(^PS(52.91,PSOTX1,0)) D Q
67 ....D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
68 ....I $D(^XTMP("SDPSO145","PAT","E",PSOTX1)) K DIE,DA,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="2////"_DT_";5////"_"X"_";3////"_7_";8////"_$S($P($G(^PS(52.91,PSOTX1,0)),"^",9)=1:"3",$P($G(^(0)),"^",9)=3:"3",1:"2")
69 ....D ^DIE K DA,DR,DIE
70 ...D SNM
71 ...I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)" K PSOTPSNM Q
72 ...K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTX1,DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";4////"_PSOTPDRD_";5////"_"S"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3_";8////"_2 K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM D
73 ....K PSOTPSNM
74 ....I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exclusion)" Q
75 ....S PSOITOT=$G(PSOITOT)+1
76 ..I $D(^PS(52.91,PSOTX1,0)) D Q
77 ...I $D(^XTMP("SDPSO145","PAT","E",PSOTX1)) K DIE,DA,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="5////"_"X" D ^DIE K DA,DIR,DR
78 ...D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
79 ...;I $P($G(^PS(52.91,PSOTX1,0)),"^",10) S PSOLXQT=1 Q
80 ...;I PSOTX2=$P($G(^PS(52.91,PSOTX1,0)),"^",8) K DIE,DA,DR S DA=PSOTX1,DIE="^PS(52.91,",DR="9////"_PSOTX3 D ^DIE K DIE,DA,DR S PSOLXQT=1 Q
81 ...;D SNM I $G(PSOTPSNM)="" Q
82 ...;K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_"@"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 D ^DIE K DA,DR,DIE
83 ...;K PSOTPSNM S PSOLXQT=1 Q
84 ..D SNM
85 ..I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)="" K PSOTPSNM Q
86 ..K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTX1,DIC("DR")="1////"_DT_";4////"_PSOTPDRD_";5////"_"S"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM D
87 ...K PSOTPSNM
88 ...I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)="" Q
89 ...S PSOETOT=$G(PSOETOT)+1
90 Q
91SNM ;
92 K PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTX2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTX2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
93 Q
94DATE ;
95 I $P($G(^PS(52.91,PSOTX1,0)),"^",10),PSOTX3'<$P(^(0),"^",10) Q
96 I PSOTX2=$P($G(^PS(52.91,PSOTX1,0)),"^",8) K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="9////"_PSOTX3_";4////"_"@" D ^DIE K DA,DR,DIE D Q
97 .S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_PSOTPDRD D ^DIE K DA,DR,DIE
98 D SNM
99 I $G(PSOTPSNM)="" K PSOTPSNM Q
100 K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_"@"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 D ^DIE K DA,DR,DIE
101 K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_PSOTPDRD D ^DIE K DA,DR,DIE
102 K PSOTPSNM
103 Q
104EWL ;
105 N PSOTPRXX
106 K PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTG2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTG2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
107 I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTG1)="" K PSOTPSNM Q
108 S PSOTPRXX=$G(^XTMP("SDPSO145","ACRX",PSOTG1))
109 K DIE,DA,DR,DIC
110 S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTG1,DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";5////"_"E"_";6////"_PSOTPSNM_";7////"_PSOTG2_";8////"_1_";10////"_PSOTPRXX S:'$G(PSONODAD) DIC("DR")=DIC("DR")_";4////"_PSOTG3
111 K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM,PSOTPSNM
112 I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTG1)="" Q
113 S PSOITOT=$G(PSOITOT)+1
114 K ^XTMP("SDPSO145","PROB",PSOTG1)
115 K ^XTMP("SDPSO145","PROB1",PSOTG1)
116 Q
Note: See TracBrowser for help on using the repository browser.