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