source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5HQ5.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 6.2 KB
Line 
1RMPR5HQ5 ;HCIOFO/ODJ - INVENTORY REPORT - BUILD ^TMP SORT ARRAY ; 20 SEP 00
2 ;;3.0;PROSTHETICS;**51,61,127**;Feb 09, 1996
3 ;
4 ;RVD -patch #61 - modified to read the new PIP files; 661.11, 661.6
5 ; 661.7, 661.9
6 Q
7 ;
8 ; Start of Report build and print. Enter here after report params.
9 ; entered by user (see RMPR5HQ4).
10 ; Also called by TaskMan if report queued.
11 ;
12 ; Variables required
13 ;
14 ; RMPR("STA")
15 ; RMPRSDT
16 ; RMPREDT
17 ; RMPRDET
18 ; RMPRSEL
19 ; {IO vars}
20 ;
21REPORT I $E(IOST)["C" W !!,"Processing report......."
22 D GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPR("STA")) ;generate ^TMP sort array
23 D CALC^RMPR5HQ6 ;calculations
24 U IO D ^RMPR5HQ2 ;print report
25 D ^%ZISC
26 ;K ^TMP($J,"RMPR5") ;make live after testing
27 N RMPR,RMPRSITE D KILL^XUSCLEAN
28 Q
29 ;
30 ; Entry point for national roll-up
31NATION N RMPRSEL,RMPRDET,RMPRSTN,RMPRSDT,RMPREDT,X,RSTN
32 S RMPRSTN="*"
33 S RMPRDET="H"
34 ;D NOW^%DTC S RMPREDT=X S %H=%H-30 D YMD^%DTC S RMPRSDT=X
35 S RMPRSDT=RMPRPIP1,RMPREDT=RMPRPIP2
36 S RMPRSEL("*")=""
37 D GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPRSTN)
38 D CALC^RMPR5HQ6 ;put calcs in TMP array
39 D MAIL^RMPR5HQ7 ;build ^TMP($J,"RMPR5A" array for mailing
40 Q
41 ;
42 ;
43 ; Generate temporary index global ^TMP($J,"RMPR5"
44 ; (as of 11/29/00 we use the 660 file, not 661.2)
45 ;
46GEN(STDT,ENDT,DETAIL,RMPRSEL,RMPRSTN) ;
47 N TNAM,FROM,EOF,DAT,HCDAT,HCPCIEN,NPGRP,NPLIN,S,HCPC,HCPCITEM
48 N OUPIEN,ITEM,ALLGRP,HCPCREF,SELECTED,STATION,QTY,STR,MULITEM
49 N ITMIEN,INVDT,SOURCE,ISCOST,PATIENT,COST
50 S TNAM="RMPR5" ;TMP global name
51 K ^TMP($J,TNAM)
52 D CURVAL(TNAM,RMPRSTN,.RMPRSEL,DETAIL)
53 ;S FROM="" S:$G(STDT)'="*" FROM=STDT-1
54 S RSTN=RMPRSTN
55 S:RMPRSTN="*" RSTN=0
56 S EOF=0,ENDT=ENDT+1
57 F RSTN=RSTN:0 S RSTN=$O(^RMPR(661.6,"XSTD",RSTN)) Q:RSTN'>0 D
58 .F RSDT=STDT:0 S RSDT=$O(^RMPR(661.6,"XSTD",RSTN,3,RSDT)) Q:(RSDT>ENDT)!(RSDT="") D Q:EOF
59 .. S OUPIEN=0
60 .. F S OUPIEN=$O(^RMPR(661.6,"XSTD",RSTN,3,RSDT,OUPIEN)) Q:OUPIEN'>0 D
61 ... S S=$G(^RMPR(661.6,OUPIEN,0))
62 ... S PATIENT=$P(S,"^",2) Q:PATIENT=""
63 ... S QTY=+$P(S,"^",5) Q:QTY<1
64 ... S HCPC=$P(S,"^",1) Q:HCPC=""
65 ... S HCPCIEN=$O(^RMPR(661.1,"B",HCPC,0)) Q:HCPCIEN=""
66 ... S STATION=RSTN Q:STATION=""
67 ... I RMPRSTN'="*",STATION'=RSTN Q
68 ... Q:'$D(^TMP($J,TNAM,"Z",HCPCIEN))
69 ... Q:$P(^TMP($J,TNAM,"Z",HCPCIEN),"^",3)=1
70 ... S HCPCITEM=HCPC_"-"_$P(S,"^",11)
71 ... S ITEM=$P(HCPCITEM,"-",2)
72 ... S:ITEM="" ITEM="?"
73 ... S ISCOST=$P(S,"^",6)
74 ...; S COST=$$PRECOST(OUPIEN,HCPCIEN,HCPCITEM,STATION)
75 ...; I COST'="" S ISCOST=COST-ISCOST
76 ...; S:COST="" ISCOST=QTY*$P(S,"^",5)
77 ... S R11=$O(^RMPR(661.11,"C",HCPCITEM,0))
78 ... S R11DAT=$G(^RMPR(661.11,R11,0))
79 ... S SOURCE=$P(R11DAT,"^",5)
80 ... S STR=^TMP($J,TNAM,"Z",HCPCIEN)
81 ... S NPGRP=$P(STR,"^",1)
82 ... S NPLIN=$P(STR,"^",2)
83 ... S HCPCREF=HCPC,$P(HCPCREF,"/",2)=HCPCIEN
84 ... I '$D(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)) D Q:'+QTY
85 .... S:+QTY ^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)=""
86 .... Q
87 ... S ^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM,OUPIEN)=QTY_"^"_ISCOST_"^"_SOURCE
88 ... Q
89 .. Q
90 Q
91 ;
92 ; Get total cost of item just prior to current issue
93PRECOST(INVIEN,HCPCIEN,HCPCITEM,STATION) ;
94 N IEN,COST,STR,LOC
95 S COST=""
96 S IEN=INVIEN,RD=RMPRSDT
97 S RD=$O(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD),-1)
98 Q:'$G(RD) COST S RIEN=$O(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD,0))
99 S STR=^RMPR(661.9,RIEN,0)
100 S COST=$P(STR,"^",9)
101 Q COST
102 ;
103 ; Get QOH for HCPC
104CURVAL(RMPRNAM,RMPRSTN,RMPRSEL,DETAIL) ;
105 N INVIEN,STR,IEN1,IEN2,LOCN,HCPCIEN,HCDAT,NPLIN,NPGRP,ALLGRP,SELECTED
106 N S,SOURCE,STATION,QOH,COST,HCPC,HCPCREF,ITEM,RSTN
107 S ALLGRP=0 S:$O(RMPRSEL(""))="*" ALLGRP=1
108 S RSTN=RMPRSTN
109 S:RMPRSTN="*" RSTN=0
110 F RSTN=RSTN:0 S RSTN=$O(^RMPR(661.9,"ASHID",RSTN)) Q:RSTN'>0 D
111 .S RH=""
112 .F S RH=$O(^RMPR(661.9,"ASHID",RSTN,RH)) Q:RH="" D
113 .. S IEN1=0
114 .. F S IEN1=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1)) Q:'+IEN1 D
115 ... S HCPCIEN=$O(^RMPR(661.1,"B",RH,0)) Q:HCPCIEN=""
116 ... I '$D(^TMP($J,RMPRNAM,"Z",HCPCIEN)) D
117 .... S S=^RMPR(661.1,HCPCIEN,0)
118 .... S NPLIN=$P(S,"^",7)
119 .... S:NPLIN="" NPLIN="999 X"
120 .... S NPGRP=$P(NPLIN," ",1) ;group num. is 1st set of digits of new line
121 .... S STR=NPGRP
122 .... S $P(STR,"^",2)=NPLIN
123 .... S ^TMP($J,RMPRNAM,"Z",HCPCIEN)=STR
124 .... Q
125 ... E D Q:$P(S,"^",3)=1
126 .... S S=^TMP($J,RMPRNAM,"Z",HCPCIEN)
127 .... S NPGRP=$P(S,"^",1)
128 .... S NPLIN=$P(S,"^",2)
129 .... Q
130 ... ;
131 ... ; Test if record matches selection criteria
132 ... ; (only needed if not all groups selected)
133 ... I 'ALLGRP D I 'SELECTED S $P(^TMP($J,RMPRNAM,"Z",HCPCIEN),"^",3)=1 Q
134 .... S SELECTED=0
135 .... I '$D(RMPRSEL(NPGRP)) Q
136 .... I DETAIL="G" S SELECTED=1 Q
137 .... I $O(RMPRSEL(NPGRP,""))="*" S SELECTED=1 Q
138 .... I '$D(RMPRSEL(NPGRP,NPLIN)) Q
139 .... I DETAIL="L" S SELECTED=1 Q
140 .... I $O(RMPRSEL(NPGRP,NPLIN,""))="*" S SELECTED=1 Q
141 .... I '$D(RMPRSEL(NPGRP,NPLIN,HCPCIEN)) Q
142 .... S SELECTED=1
143 .... Q
144 ... S RD=ENDT+1
145 ... S RD=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD),-1) Q:RD="" S RIEN=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD,""),-1) D
146 .... S HCPC=RH,S=^RMPR(661.9,RIEN,0)
147 .... S QOH=+$P(S,"^",8) Q:'QOH
148 .... S COST=$P(S,"^",9)
149 .... S ITEM=IEN1
150 .... S RS=$O(^RMPR(661.11,"C",HCPC_"-"_ITEM,0)) Q:RS=""
151 .... S SOURCE=$P($G(^RMPR(661.11,RS,0)),U,5)
152 .... S HCPCREF=HCPC,$P(HCPCREF,"/",2)=HCPCIEN
153 .... S S=$G(^TMP($J,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM))
154 .... I SOURCE="C" D
155 ..... S $P(S,"^",9)=QOH+$P(S,"^",9)
156 ..... S $P(S,"^",11)=COST+$P(S,"^",11)
157 ..... Q
158 .... E D
159 ..... S $P(S,"^",8)=QOH+$P(S,"^",8)
160 ..... S $P(S,"^",10)=COST+$P(S,"^",10)
161 ..... Q
162 .... S ^TMP($J,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM)=S
163 .... Q
164 ... Q
165 .. Q
166 Q
167 ;
168 ; return item text string given HCPC and ITEM IENs to 661.11
169 ; if null ITEMIEN passed the just return the HCPC short name text
170GETITEM(HCPCIEN,ITEMIEN) ;
171 N STR,ITEMTXT
172 S ITEMTXT=""
173 I ITEMIEN="" D G GETITEMX
174 . S STR=$G(^RMPR(661.1,HCPCIEN,0))
175 . S ITEMTXT=$P(STR,"^",2)
176 . Q
177 S HCPC=$P($G(^RMPR(661.1,HCPCIEN,0)),U,1)
178 S STR=$G(^RMPR(661.11,"C",HCPC_"-"_ITEMIEN,0))
179 I STR="" D
180 . S ITEMTXT=$P(^RMPR(661.1,HCPCIEN,0),"^",2)
181 . Q
182 E D
183 . S ITEMTXT=$P(STR,"^",1)
184 . Q
185 S:ITEMTXT="" ITEMTXT="ITEM "_ITEMIEN
186GETITEMX Q ITEMTXT
187 ;
188 ; return NPPD line text from line code (New lines only)
189NPLIN(CODE) ;
190 N I,S,LINTXT
191 S LINTXT=""
192 F I=1:1 S S=$P($T(DES+I^RMPRN62),";;",2) Q:$E(S,1,3)="END" D Q:LINTXT'=""
193 . I $P(S,";",1)=CODE S LINTXT=$P(S,";",2)
194 . Q
195 Q LINTXT
Note: See TracBrowser for help on using the repository browser.