source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPI02.m@ 623

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1RMPRPI02 ;HINCIO/ODJ - PIP Report APIs ;9/18/02 15:13
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 ;
4 Q
5 ;
6 ; LBAL - returns a ^TMP array structured as follows:-
7 ; ^TMP($J,N,L,H,I,D,S)=data (^ delimiter)
8 ;
9 ; where N = ^TMP array name (eg. RMPRPI01)
10 ; L = Location (NAME)
11 ; H = HCPCS code (eg. L5000)
12 ; I = Item number (eg. 1)
13 ; D = full FM date (eg. 3010309.135415)
14 ; S = Source (C - comercial, V - VA)
15 ;
16 ; data pc 1 = Quantity on hand
17 ; 2 = Value
18 ; 3 = Unit Cost
19 ; 4 = Vendor Desc.
20 ; 5 = HCPCS Item description
21 ; 6 = Location Desc.
22 ; 7 = Re-Order level
23 ;
24 ; Inputs:
25 ; RMPRNM - Name for ^TMP array
26 ; RMPRSTN - Station number (ptr. ^DIC(4))
27 ; RMPRLOCA - Array of Location iens, or * for all Locations.
28 ;
29 ; Outputs:
30 ; RMPRERR - 0 if no errors, +ve int. if errors
31 ; ^TMP - (see above)
32 ;
33LBAL(RMPRNM,RMPRSTN,RMPRLOCA) ;
34 N RMPRERR,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
35 N RMPR4,RMPR5
36 S RMPRERR=0
37 I $G(RMPRNM)="" S RMPRNM="RMPRPI02"
38 I $G(RMPRSTN)="" S RMPRERR=1 G LBALX
39 I '$D(RMPRLOCA)="" S RMPRLOCA="*"
40 K ^TMP($J,RMPRNM)
41 S RMPR("STATION")=RMPRSTN
42 I $G(RMPRLOCA)="*" G LBAL2
43 S RMPRH=""
44LBAL1 S RMPRH=$O(RMPRLOCA(RMPRH))
45 I RMPRH="" G LBALX
46 K RMPR
47 S RMPR("STATION")=RMPRSTN
48 S RMPR("LOCATION")=RMPRH
49LBAL2 S RMPRERR=$$NEXT^RMPRPIXE(.RMPR,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
50 I RMPRERR W !,"*** ERROR IN RMPRPIXE ROUTINE!!!",! G LBALX
51 I RMPREOF G LBAL1
52 I $G(RMPRLOCA)'="*",RMPROLD("LOCATION")'=RMPR("LOCATION") G LBAL1
53 I RMPROLD("STATION")'=RMPR("STATION") G:$G(RMPRLOCA)="*" LBALX G LBAL1
54 K RMPRE S RMPRE("IEN")=RMPR("IEN")
55 S RMPRERR=$$GET^RMPRPIX7(.RMPRE)
56 I RMPRERR W !,"*** ERROR IN RMPRPIX7 ROUTINE!!!",! G LBALX
57 K RMPR6E
58 S RMPR6E("HCPCS")=RMPR("HCPCS")
59 S RMPR6E("ITEM")=RMPR("ITEM")
60 S RMPR6E("DATE&TIME")=RMPR("DATE&TIME")
61 S RMPRERR=$$GET^RMPRPIX6(.RMPR6E)
62 K RMPR11E
63 S RMPR11E("HCPCS")=RMPR("HCPCS")
64 S RMPR11E("ITEM")=RMPR("ITEM")
65 S RMPR11E("STATION")=RMPR("STATION")
66 S RMPRERR=$$GET^RMPRPIX1(.RMPR11E)
67 I RMPRERR W !,"*** ERROR IN RMPRPIX1 ROUTINE!!!",! G LBALX
68 K RMPR11I
69 S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11E,.RMPR11I)
70 I RMPRERR W !,"*** ERROR IN RMPRPIX1 ROUTINE!!!",! G LBALX
71 S RMPRT=""
72 S $P(RMPRT,"^",1)=RMPRE("QUANTITY")
73 S $P(RMPRT,"^",2)=RMPRE("VALUE")
74 I +RMPRE("QUANTITY") D
75 . S $P(RMPRT,"^",3)=$J(RMPRE("VALUE")/RMPRE("QUANTITY"),0,2)
76 . Q
77 S $P(RMPRT,"^",4)=RMPR6E("VENDOR")
78 S $P(RMPRT,"^",5)=RMPR11E("DESCRIPTION")
79 S $P(RMPRT,"^",6)=RMPRE("LOCATION")
80 K RMPR4
81 S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPR11I("STATION"),RMPR("LOCATION"),RMPR11I("HCPCS"),RMPR11I("ITEM"),""))
82 ;next line added
83 G:RMPR4("IEN")="" LBALX
84 S RMPRERR=$$GET^RMPRPIX4(.RMPR4,,)
85 S $P(RMPRT,"^",7)=RMPR4("RE-ORDER QTY")
86 S ^TMP($J,RMPRNM,RMPRE("LOCATION"),RMPR("HCPCS"),RMPR("ITEM"),RMPR("DATE&TIME"),RMPR11I("SOURCE"))=RMPRT
87 G LBAL2
88LBALX Q RMPRERR
89 ;
90PROC(RMSUB,RS,RMPRI) ;
91 N RMDAT,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
92 N RMST2,RMTY,RM6,RM11,RMIT2,RMLOC2,RMII,I,J,K,RMIDES,RMINS,RM11DA
93 I $G(RMPRI)="*" D ALL
94 D LOC
95NOINV ;
96 ;check for other items not currently in the inventory but previously in.
97 S I=""
98 F S I=$O(^RMPR(661.11,"ASHI",RS,I)) Q:I="" F J=0:0 S J=$O(^RMPR(661.11,"ASHI",RS,I,J)) Q:J'>0 D
99 .F K=0:0 S K=$O(^RMPR(661.11,"ASHI",RS,I,J,K)) Q:K'>0 D
100 ..Q:'$D(^RMPR(661.11,K,0))
101 ..S RM11=$G(^RMPR(661.11,K,0))
102 ..Q:RM11=""
103 ..Q:$D(^TMP($J,"RMTMP",I,J))
104 ..S RMIDES=$P(RM11,U,3)
105 ..Q:($P(RM11,U,9))=1
106 ..;check what location this HCCPS/ITEM belongs to previously.
107 ..F RMII=0:0 S RMII=$O(^RMPR(661.6,"B",I,RMII)) Q:RMII'>0 D
108 ...Q:'$D(^RMPR(661.6,RMII,0))
109 ...S RM6=$G(^RMPR(661.6,RMII,0)),RMIT2=$P(RM6,U,11)
110 ...S RMTY=$P(RM6,U,4),RMST2=$P(RM6,U,13),RMLOC2=$P(RM6,U,14)
111 ...Q:'$G(RMLOC2)
112 ...I $G(RMPRI)'="*",'$D(RMPRI(RMLOC2)) Q
113 ...Q:(RMST2'=RS)!(RMIT2'=J)!(RMTY'=1)!(RMLOC2="")
114 ...Q:'$D(^RMPR(661.5,RMLOC2,0))
115 ...S RMLOC2N=$P(^RMPR(661.5,RMLOC2,0),U,1)
116 ...Q:$D(^TMP($J,RMSUB,RMLOC2N,I,J,1))
117 ...S ^TMP($J,RMSUB,RMLOC2N,I,J,1)="^^^^"_RMIDES
118 ;EXIT
119 Q
120 ;
121ALL ;process all LOCATION in a station
122 S I=""
123 F S I=$O(^RMPR(661.7,"B",I)) Q:I="" F J=0:0 S J=$O(^RMPR(661.7,"B",I,J)) Q:J'>0 D CRE
124 Q
125LOC ;process certain LOCATION.
126 F I=0:0 S I=$O(RMPRI(I)) Q:I'>0 F J=0:0 S J=$O(^RMPR(661.7,"C",I,J)) Q:J'>0 D CRE
127 Q
128 ;
129CRE ;create the tmp global
130 S RMDAT=$G(^RMPR(661.7,J,0))
131 Q:RS'=$P(RMDAT,U,5)
132 S RMUNIT=""
133 S RMHC=$P(RMDAT,U,1)
134 S RMDT=$P(RMDAT,U,2)
135 S RMSE=$P(RMDAT,U,3)
136 S RMHI=$P(RMDAT,U,4)
137 S RMST=$P(RMDAT,U,5)
138 S RMLO=$P(RMDAT,U,6)
139 S RMQU=$P(RMDAT,U,7)
140 S RMVA=$P(RMDAT,U,8)
141 S RMUN=$P(RMDAT,U,9)
142 S:$G(RMUN) RMUNIT=$$GETUNI^RMPRPIU0(RMUN)
143 S RMUC=RMVA
144 I RMVA,RMQU S RMUC=RMVA/RMQU
145 S RMRO=0
146 S RMSO="**"
147 S (RMVEN,RMLOC,RMIDES)=" "
148 I $G(RMLO),$D(^RMPR(661.5,RMLO,0)) S RMLOC=$P(^RMPR(661.5,RMLO,0),U,1)
149 S RM11=$O(^RMPR(661.11,"ASHI",RS,RMHC,RMHI,0))
150 Q:'$G(RM11)
151 Q:'$D(^RMPR(661.11,RM11,0))
152 S RM11DA=$G(^RMPR(661.11,RM11,0))
153 S RMSO=$P(RM11DA,U,5),RMIDES=$P(RM11DA,U,3),RMINS=$P(RM11DA,U,9)
154 Q:RMINS=1
155 S RM4=$O(^RMPR(661.4,"ASLHI",RS,RMLO,RMHC,RMHI,0))
156 I $G(RM4),$D(^RMPR(661.4,RM4,0)) S RMRO=$P(^RMPR(661.4,RM4,0),U,4)
157 S RMHCIEN=$O(^RMPR(661.1,"B",RMHC,0))
158 I RMHCIEN,$D(^RMPR(661.1,RMHCIEN,0)) S RMHDES=$P(^RMPR(661.1,RMHCIEN,0),U,2)
159 F K=0:0 S K=$O(^RMPR(661.6,"C",RMDT,K)) Q:K'>0 S RM6=$G(^RMPR(661.6,K,0)) D
160 .Q:RMHC'=$P(RM6,U,1)
161 .I (RMHC=$P(RM6,U,1)),(RMSE=$P(RM6,U,3)) S RMV=$P(RM6,U,12)
162 .S:$G(RMV) RMVEN=$$GETVEN^RMPRPIU0(RMV)
163 S RMPRT=RMQU_"^"_RMVA_"^"_RMUC_"^"_RMVEN_"^"_RMIDES_"^"_RMLOC_"^"_RMRO
164 S ^TMP($J,RMSUB,RMLOC,RMHC,RMHI,RMDT)=RMPRT_"^"_RMUNIT_"^"_RMSO
165 S ^TMP($J,"RMTMP",RMHC,RMHI)=""
166 Q
Note: See TracBrowser for help on using the repository browser.