source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSO55FX2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1PSO55FX2 ;ISC-BHAM/MHA - cleanup of bad p nodes and mismatched Rxs in file 55 ; 07/26/2001
2 ;;7.0;OUTPATIENT PHARMACY;**69**;DEC 1997
3 ;External reference to ^PS(55 is supported by DBIA 2228
4 ;External reference ^DGPM("AMV1" is supported by DBIA 2249
5 Q
6BEG ;
7 I '$D(DUZ) W !!!!,"* DUZ NOT DEFINED - QUITTING *" Q
8 D MSG^PSO55FX3
9 K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
10 D ^%DT K %DT
11 I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued - quitting!" Q
12 S ZTDTH=$G(Y),ZTSAVE("DUZ")="",ZTIO="",ZTRTN="EN^PSO55FX2",ZTDESC="Cleanup of bad 'P' cross-references in Pharmacy Patient file"
13 D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued To Run!",!
14 Q
15EN ;
16 I $G(^XTMP("PSO2",69))="PH1" D PH2^PSO55FX3 Q
17 S TY="PSO",JN=69 S (DFN,ZA,ZB,ZC)=0
18 I '$D(^XTMP(TY,JN)) S X1=DT,X2=+90 D C^%DTC S ^XTMP(TY,JN,0)=$G(X)_"^"_DT G EN1
19 I $D(^XTMP(TY,JN,1)) D
20 .S DFN=$P(^XTMP(TY,JN,1),"^") S:'DFN DFN=0
21 .S ZA=$P(^XTMP(TY,JN,1),"^",2) S:'ZA ZA=0
22 .S ZB=$P(^XTMP(TY,JN,1),"^",3) S:'ZB ZB=0
23 .S ZC=$P(^XTMP(TY,JN,1),"^",4) S:'ZC ZC=0
24EN1 S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUE (EDIT)^PROVIDER HOLD"
25 F S DFN=$O(^PS(55,DFN)) Q:'DFN D CHK1,CHK2 S ^XTMP(TY,JN,1)=DFN_"^"_ZA_"^"_ZB_"^"_ZC
26 D SMAIL S ^XTMP("PSO2",69)="PH1" D PH2^PSO55FX3
27 Q
28CHK1 ;for every patient go through the "P" x-ref
29 K XZ S (RB,I)=0 F S I=$O(^PS(55,DFN,"P",I)) Q:'I S RX=$P($G(^(I,0)),"^") D:RX
30 .;checks for non-existing Rxs or Rxs with no header record & if found clean it up
31 .I '$D(^PSRX(RX)) S RB=1,ZA=ZA+1,XZ(RX)="" K ^PS(55,DFN,"P",I,0) Q
32 .I '$D(^PSRX(RX,0)) S RB=1,ZA=ZA+1,XZ(RX)="" K ^PS(55,DFN,"P",I,0) Q
33 .;checks for patient mis-match
34 .I DFN'=+$P(^PSRX(RX,0),"^",2) D
35 ..S ZA=ZA+1,RB=1,XZ(RX)="" K ^PS(55,DFN,"P",I,0)
36 ..D:+$P($G(^PSRX(RX,"STA")),"^")=12 ALOG
37 D:RB RBP
38 Q
39ALOG ;
40 S CDFN=+$P(^PSRX(RX,0),"^",2)
41 Q:$P($G(^DPT(CDFN,.35)),"^")
42 S (II,JJ,CT)=0,AL="ZZZ"
43 F S II=$O(^PSRX(RX,"A",II)) Q:'II S:$P($G(^(II,0)),"^",5)["Auto Discontinued on Admission" JJ=II
44 I JJ S CDT=$P($G(^PSRX(RX,"A",JJ,0)),"^") Q:'CDT D
45 .S X1=$E(CDT,1,7),X2=-3 D C^%DTC S SDT=X-.01,EDT=X_".99999"
46 .F S SDT=$O(^DGPM("AMV1",SDT)) Q:'SDT!(SDT>EDT)!(CT) D
47 ..S PDFN=0 F S PDFN=$O(^DGPM("AMV1",SDT,PDFN)) Q:'PDFN!(PDFN=CDFN)
48 ..S:+PDFN=CDFN CT=1
49 Q:CT
50 S:JJ AL="Auto Discontinued on Admission" S (II,JJ)=0
51 F S II=$O(^PSRX(RX,"A",II)) Q:'II S:$P($G(^(II,0)),"^",5)["Auto Discontinued Due" JJ=II
52 S:JJ AL=$P(^PSRX(RX,"A",JJ,0),"^",5)
53 S DIV=$P($G(^PSRX(RX,2)),"^",9) S:DIV="" DIV=998899
54CREC ;
55 S SSN=$P($G(^DPT(CDFN,0)),"^",9) S:SSN="" SSN="N/A"
56 S NAME=$P($G(^DPT(CDFN,0)),"^")_" ("_SSN_")" S:NAME="" NAME="N/A"
57 ;S STAT=$P(STA,"^",$P($G(^PSRX(RX,"STA")),"^")+1) S:STAT="" STAT="N/A"
58 S:'$D(^XTMP(TY,JN,2,DIV,AL,CDFN,RX)) ^XTMP(TY,JN,2,DIV,AL,CDFN,RX)=NAME_"^"_$P(^PSRX(RX,0),"^")_"^"_$S(AL="ZZZ":"",1:AL),ZC=ZC+1
59 S ^XTMP(TY,JN,"Z",DIV,CDFN,RX)=""
60 Q
61 ;
62CHK2 ;for every patient go through the "P","A" x-ref
63 S J=0 F S J=$O(^PS(55,DFN,"P","A",J)) Q:'J S RX=0 F S RX=$O(^PS(55,DFN,"P","A",J,RX)) Q:'RX D
64 .;checks for non-existing Rxs or Rxs with no header record & if found clean it up
65 .I '$D(^PSRX(RX)) S:'$D(XZ(RX)) ZB=ZB+1 K ^PS(55,DFN,"P","A",J,RX) Q
66 .I '$D(^PSRX(RX,0)) S:'$D(XZ(RX)) ZB=ZB+1 K ^PS(55,DFN,"P","A",J,RX) Q
67 .;checks for patient mismatch
68 .I DFN'=+$P(^PSRX(RX,0),"^",2) D
69 ..S:'$D(XZ(RX)) ZB=ZB+1 K ^PS(55,DFN,"P","A",J,RX)
70 ..D:+$P($G(^PSRX(RX,"STA")),"^")=12 ALOG
71 K XZ Q
72RBP ;rebuild the "P" header rec
73 S (NR,LR,I)=0 F S I=$O(^PS(55,DFN,"P",I)) Q:'I S LR=I,NR=NR+1
74 S ^PS(55,DFN,"P",0)="^55.03PA^"_LR_"^"_NR
75 K NR,LR,RB Q
76 ;
77SMAIL ;
78 S ZZ="PSOFX" K ^TMP(ZZ,$J),XMY
79 I ZA!(ZB)!(ZC) D
80 .;S ^TMP(ZZ,$J,1)="**************************************************"
81 .S ^TMP(ZZ,$J,2)="*** Following cleanup has been done: ***"
82 .S ^TMP(ZZ,$J,3)="*** ***"
83 .S ^TMP(ZZ,$J,4)="*** bad P-XREF COUNT "_$E(ZA_" ",1,6)_" ***"
84 .S ^TMP(ZZ,$J,5)="*** bad PA-XREF COUNT "_$E(ZB_" ",1,6)_" ***"
85 .S ^TMP(ZZ,$J,6)="*** mismatched PATIENT COUNT "_$E(ZC_" ",1,6)_" ***"
86 .S ^TMP(ZZ,$J,7)="*** ***"
87 .I ZC D
88 ..S ^TMP(ZZ,$J,8)="*** The count of mismatched patients may ***"
89 ..S ^TMP(ZZ,$J,9)="*** include multiple counts for the same ***"
90 ..S ^TMP(ZZ,$J,10)="*** patient since bad nodes from more than ***"
91 ..S ^TMP(ZZ,$J,11)="*** one patient could point to different ***"
92 ..S ^TMP(ZZ,$J,12)="*** prescriptions for the same 'good' ***"
93 ..S ^TMP(ZZ,$J,13)="*** patient entry in the PRESCRIPTION ***"
94 ..S ^TMP(ZZ,$J,14)="*** file (#52). ***"
95 .;S ^TMP(ZZ,$J,15)="**************************************************"
96 .S ^TMP(ZZ,$J,16)=""
97 .I ZC D
98 ..S ^TMP(ZZ,$J,17)="A separate message has been sent for the following"
99 ..S ^TMP(ZZ,$J,18)="divisions. Each has one or more mismatched patients"
100 ..S ^TMP(ZZ,$J,19)="that must be reviewed for inaccurate data."
101 ..S ^TMP(ZZ,$J,20)="",XX=21
102 ..K XY S J=0 F S J=$O(^XTMP(TY,JN,"Z",J)) Q:'J D
103 ...S DIV=$P($G(^PS(59,J,0)),"^")
104 ...S (I,L)=0 F S I=$O(^XTMP(TY,JN,"Z",J,I)) Q:'I S L=L+1
105 ...S ^TMP(ZZ,$J,XX)=" "_DIV_": "_L,XX=XX+1,XY(J)=L
106 E D
107 .;S ^TMP(ZZ,$J,1)="**************************************************"
108 .S ^TMP(ZZ,$J,2)="*** No prescriptions were found with possible ***"
109 .S ^TMP(ZZ,$J,3)="*** bad 'P' or 'P','A' x-refs or prescriptions ***"
110 .S ^TMP(ZZ,$J,4)="*** associated with the wrong patient. ***"
111 .;S ^TMP(ZZ,$J,5)="**************************************************"
112 S XMY(DUZ)="",XMY("G.PL2 PATCH TRACKING@FORUM.VA.GOV")=""
113 S XMSUB="PSO*7*69 - "_$P($$SITE^VASITE(),"^",2)
114 S XMDUZ="Outpatient Pharmacy Patch 69"
115 S XMTEXT="^TMP(ZZ,$J," D ^XMD K XMY,^TMP(ZZ,$J)
116 I $D(^XTMP(TY,JN,2)) S J=0 F S J=$O(^XTMP(TY,JN,2,J)) Q:'J D
117 .S DIV=$P($G(^PS(59,J,0)),"^")
118 .S ^TMP(ZZ,$J,J,1)="This message is comprised of two sections. Section 1 lists prescriptions that"
119 .S ^TMP(ZZ,$J,J,2)="may have been automatically discontinued by mistake, either by a Date of Death"
120 .S ^TMP(ZZ,$J,J,3)="entry or by the Autocancel on Admission action for a different patient. The"
121 .S ^TMP(ZZ,$J,J,4)="second section lists other discontinued prescriptions."
122 .S ^TMP(ZZ,$J,J,5)=""
123 .S ^TMP(ZZ,$J,J,6)="Please review the following DISCONTINUED prescriptions for the "
124 .S ^TMP(ZZ,$J,J,8)=DIV_" (division name) Outpatient Site."
125 .S ^TMP(ZZ,$J,J,9)=""
126 .S ^TMP(ZZ,$J,J,10)="TOTAL COUNT OF UNIQUE PATIENT IS "_$G(XY(J))
127 .S ^TMP(ZZ,$J,J,11)=""
128 .S YY=0,$E(S1,36)="",$E(S2,12)="",K="",$P(UL,"=",66)=""
129 .S ^TMP(ZZ,$J,J,12)=UL,^TMP(ZZ,$J,J,13)="SECTION 1",^TMP(ZZ,$J,J,14)=""
130 .S XX=15 F S K=$O(^XTMP(TY,JN,2,J,K)) Q:K="" D
131 ..D:'YY
132 ...S ^TMP(ZZ,$J,J,XX)="Following prescriptions may have been automatically discontinued by mistake,",XX=XX+1
133 ...S ^TMP(ZZ,$J,J,XX)="either by a Date of Death entry or by the Autocancel on Admission action for",XX=XX+1
134 ...S ^TMP(ZZ,$J,J,XX)="a different patient.",XX=XX+1
135 ...S ^TMP(ZZ,$J,J,XX)="",XX=XX+1
136 ...S ^TMP(ZZ,$J,J,XX)=$E("NAME (SSN#)"_S1,1,35)_$E("Rx #"_S2,1,12)_$S(K="ZZZ":"",1:"Discontinued Reason"),XX=XX+1
137 ...S ^TMP(ZZ,$J,J,XX)="",XX=XX+1 S:K["Auto Discontinued" YY=1
138 ..D:K="ZZZ"
139 ...I YY S ^TMP(ZZ,$J,J,XX)="",XX=XX+1,YY=0
140 ...E S ^TMP(ZZ,$J,J,XX)="There were no entries that were automatically discontinued.",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
141 ...S ^TMP(ZZ,$J,J,XX)=UL,XX=XX+1
142 ...S ^TMP(ZZ,$J,J,XX)="SECTION 2",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
143 ...S ^TMP(ZZ,$J,J,XX)="The following prescriptions may have been discontinued manually:",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
144 ..S L=0 F S L=$O(^XTMP(TY,JN,2,J,K,L)) Q:'L D
145 ...S ^TMP(ZZ,$J,J,XX)=""
146 ...S II=0 F S II=$O(^XTMP(TY,JN,2,J,K,L,II)) Q:'II D
147 ....S QQ=^XTMP(TY,JN,2,J,K,L,II)
148 ....I $D(^TMP(ZZ,$J,J,XX)) S ^TMP(ZZ,$J,J,XX)=$E($P(QQ,"^")_S1,1,35)_$E($P(QQ,"^",2)_S2,1,12)_$S(K="ZZZ":"",1:$E($P(QQ,"^",3),1,32)),XX=XX+1
149 ....E S ^TMP(ZZ,$J,J,XX)=S1_$E($P(QQ,"^",2)_S2,1,12)_$S(K="ZZZ":"",1:$E($P(QQ,"^",3),1,32)),XX=XX+1
150 .D:'$D(^XTMP(TY,JN,2,J,"ZZZ"))
151 ..S ^TMP(ZZ,$J,J,XX)="",XX=XX+1,^TMP(ZZ,$J,J,XX)=UL,XX=XX+1
152 ..S ^TMP(ZZ,$J,J,XX)="SECTION 2",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
153 ..S ^TMP(ZZ,$J,J,XX)="There were no entries that were manually discontinued.",XX=XX+1,^TMP(ZZ,$J,J,XX)=""
154 .S XMY(DUZ)="",XMDUZ="Search for possible invalid Prescription status"
155 .S XMSUB="IMPORTANT - "_$G(DIV)_": Prescriptions to be reviewed."
156 .S XMTEXT="^TMP(ZZ,$J,J," D ^XMD K XMY,^TMP(ZZ,$J,J)
157END K ^XTMP(TY,JN),^TMP(ZZ,$J),XMY,XMDUZ,ZA,ZB,ZC,DFN,CDFN,RX,RB,XY,XX,TY,JN,ZZ,I,J,K,L,NAME,DIV,STA,STAT,X1,X2
158 Q
Note: See TracBrowser for help on using the repository browser.