source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREXT.m@ 1803

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1RMPREXT ;PHX/HNC-DATA EXTRACT FOR Nppd ;4/20/1995
2 ;;3.0;PROSTHETICS;**12,18,24,64,59,103,106,109,113,126,138**;Feb 09, 1996;Build 11
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;DBIA #4599, Vendor file read 38,39,18.3,8.3
6 ;
7 ;patch 113 - roll back to 5000 lines
8 ; add count of records to summary message and
9 ; count by station number to summary total
10 ; add site- to ien, use ~ as data delimiter
11 ; add d1 and d2 flags for EXE parsing tool
12 ;
13 ;patch 126/hnc - check length, bug in GUI ignores DD field length
14 ;
15 ;patch 60/hnc - DDC interface, include DDC data fields.
16 ; 8/23/2006
17 ;
18EN ;extract from 660
19 N %ZIS,ZTIO,ZTRTN,ZTSK,ZTDESC
20 S %ZIS="Q" D ^%ZIS Q:POP
21 I $D(IO("Q")) D QUE,HOME^%ZIS Q
22PR1 ;refresh amis codes
23 D ^RMPREXR
24EN1 ;pass dates if needed
25 S RMPRSEND=$P(XMRG,"*",5)
26 S DIC="^RMPR(660,",DR=".01:100",DIQ(0)="EN"
27 S RMPRB=0,RMPRCNT=0,RMPRSUB="B1 ",RMPRRECC=0,COUNT=0
28 K ^TMP("RMPR",$J)
29 F S RMPRB=$O(^RMPR(660,"B",RMPRB)) Q:(RMPRB>RMPRDT2)!(RMPRB'>0) D
30 .Q:RMPRB<RMPRDT1
31 .;date range check complete
32 .;pick up mult records with same date
33 .S RMPRA=0
34 .F S RMPRA=$O(^RMPR(660,"B",RMPRB,RMPRA)) Q:RMPRA'>0 D
35 ..S RMPRRECC=RMPRRECC+1
36 ..S DA=RMPRA,DIQ="RMPR"
37 ..S DIC="^RMPR(660,",DR=".01:100",DIQ(0)="EN"
38 ..D EN^DIQ1
39 ..;verify field length
40 ..;Brief Description
41 ..I $D(RMPR(660,RMPRA,24,"E")) D
42 ...I $L(RMPR(660,RMPRA,24,"E"))>60 S RMPR(660,RMPRA,24,"E")=$E(RMPR(660,RMPRA,24,"E"),1,60)
43 ..;Deliver To
44 ..I $D(RMPR(660,RMPRA,25,"E")) D
45 ...I $L(RMPR(660,RMPRA,25,"E"))>30 S RMPR(660,RMPRA,25,"E")=$E(RMPR(660,RMPRA,25,"E"),1,30)
46 ..;Remarks
47 ..I $D(RMPR(660,RMPRA,16,"E")) D
48 ...I $L(RMPR(660,RMPRA,16,"E"))>60 S RMPR(660,RMPRA,16,"E")=$E(RMPR(660,RMPRA,16,"E"),1,60)
49 ..D LINECK
50 ..;parse array
51 ..S RMPRC=0
52 ..F S RMPRC=$O(RMPR(660,RMPRC)) Q:RMPRC'>0 D TMP
53 ;clean up before calling mailman
54 K DFN,RMPRFLD,RMPRE,RMPRCNT,DFN,RMPRA,RMPRC,DIQ,DIC,DR,DA,RMPRDT1,RMPRDT2
55 S XMSUB="B1-F " D MAIL,EXIT
56 Q
57LINECK ;check the message line limit (5000)
58 I RMPRCNT>5000 S XMSUB=RMPRSUB D MAIL K ^TMP("RMPR",$J) S RMPRCNT=0
59 Q
60TMP ;format for mailman ^TMP(namespace,$J,counter)=record,field,value
61 S RMPRFLD=0
62 F S RMPRFLD=$O(RMPR(660,RMPRC,RMPRFLD)) Q:RMPRFLD'>0 D
63 .S RMPRCNT=RMPRCNT+1,RMPRE=0,DFN=0
64 .S RMPRE=$O(RMPR(660,RMPRC,RMPRFLD,RMPRE)) Q:RMPRE=""
65 .;add station number - to ien
66 .S IENSITE=$P($$SITE^VASITE,U,3),IENSITE=IENSITE_"-"
67 .;strip the ~ for TEXT file
68 .I RMPRFLD'=".01" S ^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~"_RMPRFLD_"~"_$TR(RMPR(660,RMPRC,RMPRFLD,RMPRE),"~","/")_U
69 .I RMPRFLD=".01" S ^TMP("RMPR",$J,RMPRCNT)="d1~"_IENSITE_RMPRC_"~"_RMPRFLD_"~"_$TR(RMPR(660,RMPRC,RMPRFLD,RMPRE),"~","/")_U
70 .;get SSN
71 .I RMPRFLD=".02" D
72 . .S DFN=$P(^RMPR(660,RMPRC,0),U,2)
73 . .D DEM^VADPT,ADD^VADPT,SVC^VADPT
74 . .S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~644~"_VA("PID")_U
75 . .;DOB int
76 . .I $G(VADM(3)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.3~"_$P(VADM(3),U,1)_U
77 . .;DOB ext
78 . .I $G(VADM(3)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.31~"_$P(VADM(3),U,2)_U
79 . .;Sex, int
80 . .I $G(VADM(5))'="" S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.5~"_$P(VADM(5),U,1)_U
81 . .;DOD int
82 . .I $G(VADM(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.6~"_$P(VADM(6),U,1)_U
83 . .;DOD ext
84 . .I $G(VADM(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.61~"_$P(VADM(6),U,2)_U
85 . .;patient zip
86 . .I $G(VAPA(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.62~"_VAPA(6)_U
87 . .;patient county name
88 . .I $G(VAPA(7)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.63~"_$P(VAPA(7),U,2)_U
89 . .;city
90 . .I $G(VAPA(4)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.66~"_VAPA(4)_U
91 . .;requestor service
92 . .;O INDICATOR
93 . .I $P($G(VASV(11)),U,1)>0 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.80~"_$P(VASV(11),U,1)_U
94 . .I $P($G(VASV(12)),U,1)>0 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.81~"_$P(VASV(12),U,1)_U
95 . .I $P($G(VASV(13)),U,1)>0 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.82~"_$P(VASV(13),U,1)_U
96 . .K VASV
97 . .;
98 . .;ICN
99 . .S ICN=$$GETICN^MPIF001(DFN)
100 . .I +ICN'=-1 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.64~"_ICN_U
101 . .;CMOR
102 . .S CMOR=$$GETVCCI^MPIF001(DFN)
103 . .I +CMOR'=-1 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.65~"_CMOR_U
104 .;vendor info
105 .I RMPRFLD=7 D
106 ..;N DIC,DR,DA
107 ..S DIC="^PRC(440,"
108 ..S DA=$P(^RMPR(660,RMPRC,0),U,9)
109 ..Q:+DA'>0
110 ..S DR="38;39;18.3;8.3",DIQ="TAXID(",DIQ(0)="E"
111 ..D EN^DIQ1
112 ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.738~"_TAXID(440,DA,38,"E")_U
113 ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.739~"_TAXID(440,DA,39,"E")_U
114 ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.7183~"_TAXID(440,DA,18.3,"E")_U
115 ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.783~"_TAXID(440,DA,8.3,"E")_U
116 ;
117 K VA("PID"),RMPR,VADM,VAPA,ICN,CMOR,TAXID
118 Q
119MAIL ;pack it up and send it off
120 S XMTEXT="^TMP(""RMPR"",$J,"
121MAILS ;entry point to send summary msg
122 S XMDUZ=.5
123 S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")=""
124 S XMSUB=XMSUB_" Extract From "_$P($$SITE^VASITE,U,2)
125 D ^XMD
126 ;keep track of messages sent
127 S RMPRM(XMZ)=XMZ_U
128 S COUNT=COUNT+1
129 Q
130QUE ;TaskMan Queue
131 S ZTIO=ION_";"_IOST K IO("Q")
132 S ZTRTN="PR1^RMPREXT"
133 S ZTDESC="Prosthetics National Data Extract"
134 K ZTSK D ^%ZTLOAD I $G(ZTSK) U IO(0) W !,"<REQUEST QUEUED>"
135 Q
136EXIT ;exit point
137 ;send summary msg
138 S RMPRM(1)="Message Numbers Created Below, Site^Total Record #:"_U_$P($$SITE^VASITE,U,3)_U_$P($$SITE^VASITE,U,2)_U_RMPRRECC_U
139 S XMSUB=RMPRSUB_"Summary ",XMTEXT="RMPRM("
140 D MAILS
141 K ^TMP("RMPR",$J),XMTEXT,XMDUZ,XMY,XMSUB,RMPRM
142 ;send message to PCM group to let them know Austin should have all mail.
143 S RMPRMM(1)="Site^Total Record # ^ Total Message #:"_U_$P($$SITE^VASITE,U,3)_U_$P($$SITE^VASITE,U,2)_U_RMPRRECC_U_COUNT
144 S XMTEXT="RMPRMM("
145 S XMSUB="NPPD Summary Update From "_$P($$SITE^VASITE,U,2)
146 S XMY("VHACOPSASPIPReport@med.va.gov")=""
147 S XMDUZ=.5
148 D ^XMD
149 K XMTEXT,XMDUZ,XMY,XMSUB,RMPRRECC,COUNT,RMPRMM,RMPRSEND,IENSITE
150 Q
151 ;
152PR2 ;Bundle open obligations on 2319
153 S XMDUZ=.5
154 S XMY("G.RMPR SERVER")=""
155 S XMSUB="Prosthetics Data Extract Open Obligations"
156 S RMPRMSG(1)="The National Data Server has been activated today by Prosthetics HQ."
157 S RMPRMSG(2)="Data has been collected for all open obligations."
158 S RMPRMSG(3)=""
159 S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1)
160 S RMPRMSG(5)=""
161 S XMTEXT="RMPRMSG("
162 D ^XMD
163 K RMPRMSG
164 K ^TMP("RMPR",$J)
165 S RMPRB=0,RMPRCNT=0,RMPRSUB="B2 "
166 S DIC="^RMPR(660,",DR=".01:83",DIQ(0)="EN"
167 F S RMPRB=$O(^RMPR(660,RMPRB)) Q:RMPRB'>0 D
168 .I $G(^RMPR(660,RMPRB,0))="" Q
169 .S RMPRA=^RMPR(660,RMPRB,0)
170 .;delivery date not null
171 .Q:$P(RMPRA,U,12)'=""
172 .S RMPRX=$P($G(^RMPR(660,RMPRB,1)),U,1)
173 .;has an IFCAP transaction number
174 .Q:$P(RMPRX,U,1)=""
175 .;refresh amis data
176 .D
177 ..N ITM,TYPE,NEW,REPAIR
178 ..S ITM=$P(RMPRA,U,6),TYPE=$P(RMPRA,U,4)
179 ..Q:ITM=""
180 ..Q:TYPE=""
181 ..S NEW=$P($G(^RMPR(661,ITM,0)),U,3)
182 ..S REPAIR=$P($G(^RMPR(661,ITM,0)),U,4)
183 ..I TYPE="X" S $P(^RMPR(660,RMPRB,"AM"),U,5)=REPAIR,$P(^("AM"),U,9)="" Q
184 ..S $P(^RMPR(660,RMPRB,"AM"),U,9)=NEW,$P(^("AM"),U,5)=""
185 .;get data
186 .S DA=RMPRB,DIQ="RMPR" D EN^DIQ1,LINECK
187 .S RMPRC=0
188 .F S RMPRC=$O(RMPR(660,RMPRC)) Q:RMPRC'>0 D LINECK,TMP
189 K DFN,RMPRFLD,RMPRC,RMPRA,RMPRB,RMPRX,RMPRCNT,RMPRE,DR,DIC,DIQ,DA
190 S XMSUB="B2-F " D MAIL,EXIT
191 D ^%ZISC
192 Q
193 ;END
Note: See TracBrowser for help on using the repository browser.