source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPI02.m@ 1550

RMPRPI02 ;HINCIO/ODJ - PIP Report APIs ;9/18/02  15:13
 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
 ;
 Q
 ;
 ; LBAL - returns a ^TMP array structured as follows:-
 ;        ^TMP($J,N,L,H,I,D,S)=data (^ delimiter)
 ;
 ;        where N = ^TMP array name (eg. RMPRPI01)
 ;              L = Location (NAME)
 ;              H = HCPCS code (eg. L5000)
 ;              I = Item number (eg. 1)
 ;              D = full FM date (eg. 3010309.135415)
 ;              S = Source (C - comercial, V - VA)
 ;
 ;      data pc 1 = Quantity on hand
 ;              2 = Value
 ;              3 = Unit Cost
 ;              4 = Vendor Desc.
 ;              5 = HCPCS Item description
 ;              6 = Location Desc.
 ;              7 = Re-Order level
 ;
 ; Inputs:
 ;    RMPRNM   - Name for ^TMP array
 ;    RMPRSTN  - Station number (ptr. ^DIC(4))
 ;    RMPRLOCA - Array of Location iens, or * for all Locations.
 ;
 ; Outputs:
 ;    RMPRERR  - 0 if no errors, +ve int. if errors
 ;    ^TMP     - (see above)
 ;
LBAL(RMPRNM,RMPRSTN,RMPRLOCA) ;
 N RMPRERR,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
 N RMPR4,RMPR5
 S RMPRERR=0
 I $G(RMPRNM)="" S RMPRNM="RMPRPI02"
 I $G(RMPRSTN)="" S RMPRERR=1 G LBALX
 I '$D(RMPRLOCA)="" S RMPRLOCA="*"
 K ^TMP($J,RMPRNM)
 S RMPR("STATION")=RMPRSTN
 I $G(RMPRLOCA)="*" G LBAL2
 S RMPRH=""
LBAL1 S RMPRH=$O(RMPRLOCA(RMPRH))
 I RMPRH="" G LBALX
 K RMPR
 S RMPR("STATION")=RMPRSTN
 S RMPR("LOCATION")=RMPRH
LBAL2 S RMPRERR=$$NEXT^RMPRPIXE(.RMPR,"XSLHIDS","",1,.RMPROLD,.RMPREOF)
 I RMPRERR W !,"*** ERROR IN RMPRPIXE ROUTINE!!!",! G LBALX
 I RMPREOF G LBAL1
 I $G(RMPRLOCA)'="*",RMPROLD("LOCATION")'=RMPR("LOCATION") G LBAL1
 I RMPROLD("STATION")'=RMPR("STATION") G:$G(RMPRLOCA)="*" LBALX G LBAL1
 K RMPRE S RMPRE("IEN")=RMPR("IEN")
 S RMPRERR=$$GET^RMPRPIX7(.RMPRE)
 I RMPRERR W !,"*** ERROR IN RMPRPIX7 ROUTINE!!!",! G LBALX
 K RMPR6E
 S RMPR6E("HCPCS")=RMPR("HCPCS")
 S RMPR6E("ITEM")=RMPR("ITEM")
 S RMPR6E("DATE&TIME")=RMPR("DATE&TIME")
 S RMPRERR=$$GET^RMPRPIX6(.RMPR6E)
 K RMPR11E
 S RMPR11E("HCPCS")=RMPR("HCPCS")
 S RMPR11E("ITEM")=RMPR("ITEM")
 S RMPR11E("STATION")=RMPR("STATION")
 S RMPRERR=$$GET^RMPRPIX1(.RMPR11E)
 I RMPRERR W !,"*** ERROR IN RMPRPIX1 ROUTINE!!!",! G LBALX
 K RMPR11I
 S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11E,.RMPR11I)
 I RMPRERR W !,"*** ERROR IN RMPRPIX1 ROUTINE!!!",! G LBALX
 S RMPRT=""
 S $P(RMPRT,"^",1)=RMPRE("QUANTITY")
 S $P(RMPRT,"^",2)=RMPRE("VALUE")
 I +RMPRE("QUANTITY") D
 . S $P(RMPRT,"^",3)=$J(RMPRE("VALUE")/RMPRE("QUANTITY"),0,2)
 . Q
 S $P(RMPRT,"^",4)=RMPR6E("VENDOR")
 S $P(RMPRT,"^",5)=RMPR11E("DESCRIPTION")
 S $P(RMPRT,"^",6)=RMPRE("LOCATION")
 K RMPR4
 S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPR11I("STATION"),RMPR("LOCATION"),RMPR11I("HCPCS"),RMPR11I("ITEM"),""))
 ;next line added
 G:RMPR4("IEN")="" LBALX
 S RMPRERR=$$GET^RMPRPIX4(.RMPR4,,)
 S $P(RMPRT,"^",7)=RMPR4("RE-ORDER QTY")
 S ^TMP($J,RMPRNM,RMPRE("LOCATION"),RMPR("HCPCS"),RMPR("ITEM"),RMPR("DATE&TIME"),RMPR11I("SOURCE"))=RMPRT
 G LBAL2
LBALX Q RMPRERR
 ;
PROC(RMSUB,RS,RMPRI) ;
 N RMDAT,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
 N RMST2,RMTY,RM6,RM11,RMIT2,RMLOC2,RMII,I,J,K,RMIDES,RMINS,RM11DA
 I $G(RMPRI)="*" D ALL
 D LOC
NOINV ;
 ;check for other items not currently in the inventory but previously in.
 S I=""
 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
 .F K=0:0 S K=$O(^RMPR(661.11,"ASHI",RS,I,J,K)) Q:K'>0  D
 ..Q:'$D(^RMPR(661.11,K,0))
 ..S RM11=$G(^RMPR(661.11,K,0))
 ..Q:RM11=""
 ..Q:$D(^TMP($J,"RMTMP",I,J))
 ..S RMIDES=$P(RM11,U,3)
 ..Q:($P(RM11,U,9))=1
 ..;check what location this HCCPS/ITEM belongs to previously. 
 ..F RMII=0:0 S RMII=$O(^RMPR(661.6,"B",I,RMII)) Q:RMII'>0  D
 ...Q:'$D(^RMPR(661.6,RMII,0))
 ...S RM6=$G(^RMPR(661.6,RMII,0)),RMIT2=$P(RM6,U,11)
 ...S RMTY=$P(RM6,U,4),RMST2=$P(RM6,U,13),RMLOC2=$P(RM6,U,14)
 ...Q:'$G(RMLOC2)
 ...I $G(RMPRI)'="*",'$D(RMPRI(RMLOC2)) Q
 ...Q:(RMST2'=RS)!(RMIT2'=J)!(RMTY'=1)!(RMLOC2="")
 ...Q:'$D(^RMPR(661.5,RMLOC2,0))
 ...S RMLOC2N=$P(^RMPR(661.5,RMLOC2,0),U,1)
 ...Q:$D(^TMP($J,RMSUB,RMLOC2N,I,J,1))
 ...S ^TMP($J,RMSUB,RMLOC2N,I,J,1)="^^^^"_RMIDES
 ;EXIT
 Q
 ;
ALL ;process all LOCATION in a station
 S I=""
 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
 Q
LOC ;process certain LOCATION.
 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
 Q
 ;
CRE ;create the tmp global
 S RMDAT=$G(^RMPR(661.7,J,0))
 Q:RS'=$P(RMDAT,U,5)
 S RMUNIT=""
 S RMHC=$P(RMDAT,U,1)
 S RMDT=$P(RMDAT,U,2)
 S RMSE=$P(RMDAT,U,3)
 S RMHI=$P(RMDAT,U,4)
 S RMST=$P(RMDAT,U,5)
 S RMLO=$P(RMDAT,U,6)
 S RMQU=$P(RMDAT,U,7)
 S RMVA=$P(RMDAT,U,8)
 S RMUN=$P(RMDAT,U,9)
 S:$G(RMUN) RMUNIT=$$GETUNI^RMPRPIU0(RMUN)
 S RMUC=RMVA
 I RMVA,RMQU S RMUC=RMVA/RMQU
 S RMRO=0
 S RMSO="**"
 S (RMVEN,RMLOC,RMIDES)="         "
 I $G(RMLO),$D(^RMPR(661.5,RMLO,0)) S RMLOC=$P(^RMPR(661.5,RMLO,0),U,1)
 S RM11=$O(^RMPR(661.11,"ASHI",RS,RMHC,RMHI,0))
 Q:'$G(RM11)
 Q:'$D(^RMPR(661.11,RM11,0))
 S RM11DA=$G(^RMPR(661.11,RM11,0))
 S RMSO=$P(RM11DA,U,5),RMIDES=$P(RM11DA,U,3),RMINS=$P(RM11DA,U,9)
 Q:RMINS=1
 S RM4=$O(^RMPR(661.4,"ASLHI",RS,RMLO,RMHC,RMHI,0))
 I $G(RM4),$D(^RMPR(661.4,RM4,0)) S RMRO=$P(^RMPR(661.4,RM4,0),U,4)
 S RMHCIEN=$O(^RMPR(661.1,"B",RMHC,0))
 I RMHCIEN,$D(^RMPR(661.1,RMHCIEN,0)) S RMHDES=$P(^RMPR(661.1,RMHCIEN,0),U,2)
 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
 .Q:RMHC'=$P(RM6,U,1)
 .I (RMHC=$P(RM6,U,1)),(RMSE=$P(RM6,U,3)) S RMV=$P(RM6,U,12)
 .S:$G(RMV) RMVEN=$$GETVEN^RMPRPIU0(RMV)
 S RMPRT=RMQU_"^"_RMVA_"^"_RMUC_"^"_RMVEN_"^"_RMIDES_"^"_RMLOC_"^"_RMRO
 S ^TMP($J,RMSUB,RMLOC,RMHC,RMHI,RMDT)=RMPRT_"^"_RMUNIT_"^"_RMSO
 S ^TMP($J,"RMTMP",RMHC,RMHI)=""
 Q