source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIUF.m@ 1076

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

initial load of WorldVistAEHR
File size: 3.6 KB
Line 
1RMPRPIUF ;HINCIO/ODJ - APIs for Current Stock file 661.7 ;3/8/01
2 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
3 Q
4 ;*****
5 ;
6 ; Inputs:
7 ; RMPR - an array with the following elements...
8 ; RMPR("STATION IEN") - Station ien (ptr ^DIC(4,)
9 ; RMPR("LOCATION IEN") - Location ien (ptr ^RMPR(661.5,)
10 ; RMPR("VENDOR IEN") - Vendor ien
11 ; RMPR("HCPCS") - HCPCS code (eg E0111)
12 ; RMPR("ITEM") - HCPCS Item number (eg 1)
13 ; RMPR("ISSUED QTY") - Quantity Issued
14 ; RMPR("ISSUED VALUE") - Issue Value
15 ;
16 ; RMPRERR - function return...
17 ; 0 - no errors
18 ; 1 - null Station ien input
19 ; 2 - null Location ien input
20 ; 3 - null HCPCS code input
21 ; 4 - null Item input
22 ; 5 - issued qty not greater than 0
23 ; 6 - problem with 661.7 file
24 ; 7 - null Vendor input
25 ; 8 - problem with 661.6 file
26FIFO(RMPR) ;
27 N RMPRERR,RMPRK,RMPROLD,RMPREOF,RMPR7,RMPR7I,RMPRIBAL,RMPRVBAL
28 N RMPRUVAL,RMPRI,RMPR6,RMPR6I,RMPR7U
29 S RMPRERR=0
30 S RMPRK("STATION")=$G(RMPR("STATION IEN"))
31 I RMPRK("STATION")="" S RMPRERR=1 G FIFOX
32 S RMPRK("LOCATION")=$G(RMPR("LOCATION IEN"))
33 I RMPRK("LOCATION")="" S RMPRERR=2 G FIFOX
34 S RMPRK("HCPCS")=$G(RMPR("HCPCS"))
35 I RMPRK("HCPCS")="" S RMPRERR=3 G FIFOX
36 S RMPRK("ITEM")=$G(RMPR("ITEM"))
37 I RMPRK("ITEM")="" S RMPRERR=4 G FIFOX
38 I $G(RMPR("VENDOR IEN"))="" S RMPRERR=7 G FIFOX
39 I '+$G(RMPR("ISSUED QTY")) S RMPRERR=5 G FIFOX
40 S RMPRIBAL=RMPR("ISSUED QTY") ; init issued qty. balance
41 S RMPRVBAL=+$G(RMPR("ISSUED VALUE")) ; init issue value balance
42 S RMPRUVAL=RMPRVBAL/RMPRIBAL ; unit cost per issued item
43 ;
44 ; Lock 661.7
45 L +^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
46 ;
47 ; Primary loop on all records for Stn, Loc, HCPCS and Item until stock
48 ; depleted by the issued amount
49FIFOA S RMPRERR=$$NEXT^RMPRPIXE(.RMPRK,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
50 I RMPRERR S RMPRERR=6 G FIFOU
51 I RMPREOF G FIFOU
52 I RMPRK("ITEM")'=RMPROLD("ITEM") G FIFOU
53 I RMPRK("HCPCS")'=RMPROLD("HCPCS") G FIFOU
54 I RMPRK("LOCATION")'=RMPROLD("LOCATION") G FIFOU
55 I RMPRK("STATION")'=RMPROLD("STATION") G FIFOU
56 K RMPR7 S RMPR7("IEN")=RMPRK("IEN")
57 S RMPRERR=$$GET^RMPRPIX7(.RMPR7) ; read in current stock rec.
58 I RMPRERR S RMPRERR=6 G FIFOU
59 K RMPR7I
60 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
61 I RMPRERR S RMPRERR=6 G FIFOU
62 ;
63 ; 2nd Loop on 661.6 transactions so as to match vendor
64 S RMPRI=""
65FIFOB S RMPRI=$O(^RMPR(661.6,"XHDS",RMPR7I("HCPCS"),RMPR7I("DATE&TIME"),RMPR7I("SEQUENCE"),RMPRI))
66 I RMPRI="" G FIFOA
67 K RMPR6 S RMPR6("IEN")=RMPRI S RMPRERR=$$GET^RMPRPIX6(.RMPR6)
68 I RMPRERR S RMPRERR=8 G FIFOU
69 S RMPRERR=$$VNDIEN^RMPRPIX6(.RMPR6)
70 I RMPRERR S RMPRERR=8 G FIFOU
71 I RMPR6("VENDOR IEN")'=RMPR("VENDOR IEN") G FIFOB
72 K RMPR7U
73 S RMPR7U("IEN")=RMPR7("IEN")
74 S RMPR7U("QUANTITY")=RMPR7("QUANTITY")
75 S RMPR7U("VALUE")=RMPR7("VALUE")
76 ;
77 ; If issued balance less than on-hand quantity then update
78 ; the on-hand record
79 I RMPRIBAL<RMPR7U("QUANTITY") D
80 . S RMPR7U("QUANTITY")=RMPR7U("QUANTITY")-RMPRIBAL
81 . S RMPR7U("VALUE")=RMPR7U("VALUE")-RMPRVBAL
82 . S RMPRERR=$$UPD^RMPRPIX7(.RMPR7U,)
83 . S RMPRIBAL=0
84 . Q
85 ;
86 ; If issued balance not less than on-hand quantity then delete
87 ; the on-hand record
88 E D
89 . S RMPRIBAL=RMPRIBAL-RMPR7U("QUANTITY")
90 . S RMPRVBAL=RMPRVBAL-($J(RMPR7U("QUANTITY")*RMPRUVAL,0,2))
91 . S RMPRERR=$$DEL^RMPRPIX7(.RMPR7U)
92 . Q
93 I RMPRERR S RMPRERR=6 G FIFOU
94 G:RMPRIBAL FIFOB ; next transaction if still got issue balance
95 ;
96 ; exit points
97FIFOU L -^RMPR(661.7,"XSLHIDS",RMPR("STATION IEN"),RMPR("LOCATION IEN"),RMPR("HCPCS"),RMPR("ITEM"))
98FIFOX Q RMPRERR
Note: See TracBrowser for help on using the repository browser.