RMPRPI01 ;HINCIO/ODJ - PIP Report APIs ;9/18/02 15:13
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
;
Q
;
;***** HBAL - returns a ^TMP array structured as follows:-
; ^TMP($J,N,H,I,D,S,L)=data (^ delimiter)
;
; where N = ^TMP array name (eg. RMPRPI01)
; H = HCPCS code (eg. L5000)
; I = Item number (eg. 1)
; D = full FM date (eg. 3010309.135415)
; S = Source (C - comercial, V - VA)
; L = Location ien (ptr. ^RMPR(661.5,)
;
; 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))
; RMPRHCPC - Array of HCPCS codes, or * for all HCPCS.
;
; Outputs:
; RMPRERR - 0 if no errors, +ve int. if errors
; ^TMP - (see above)
;
HBAL(RMPRNM,RMPRSTN,RMPRHCPC) ;
N RMPRERR,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
N RMPREI,RMPR4
S RMPRERR=0
I $G(RMPRNM)="" S RMPRNM="RMPRPI01"
I $G(RMPRSTN)="" S RMPRERR=1 G HBALX
I '$D(RMPRHCPC) S RMPRHCPC="*"
K ^TMP($J,RMPRNM)
S RMPR("STATION")=RMPRSTN
I $G(RMPRHCPC)="*" G HBAL2
S RMPRH=""
HBAL1 S RMPRH=$O(RMPRHCPC(RMPRH))
I RMPRH="" G HBALX
K RMPR
S RMPR("STATION")=RMPRSTN
S RMPR("HCPCS")=RMPRH
HBAL2 S RMPRERR=$$NEXT^RMPRPIXE(.RMPR,"XSHIDS","",1,.RMPROLD,.RMPREOF)
I RMPRERR G HBALX
I RMPREOF G HBALX
I $G(RMPRHCPC)'="*",RMPROLD("HCPCS")'=RMPR("HCPCS") G HBAL1
I RMPROLD("STATION")'=RMPR("STATION") G:$G(RMPRHCPC)="*" HBAL2 G HBAL1
K RMPRE M RMPRE=RMPR
S RMPRERR=$$GET^RMPRPIX7(.RMPRE)
I RMPRERR G HBALX
K RMPREI S RMPRERR=$$ETOI^RMPRPIX7(.RMPRE,.RMPREI)
I RMPRERR G HBALX
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 G HBALX
K RMPR11I
S RMPRERR=$$ETOI^RMPRPIX1(.RMPR11E,.RMPR11I)
I RMPRERR G HBALX
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"),RMPREI("LOCATION"),RMPR11I("HCPCS"),RMPR11I("ITEM"),""))
;next line added
G:RMPR4("IEN")="" HBAL2
S RMPRERR=$$GET^RMPRPIX4(.RMPR4)
S $P(RMPRT,"^",7)=RMPR4("RE-ORDER QTY")
S ^TMP($J,RMPRNM,RMPR("HCPCS"),RMPR("ITEM"),RMPR("DATE&TIME"),RMPR11I("SOURCE"),RMPREI("LOCATION"))=RMPRT
G HBAL2
HBALX Q RMPRERR
;
PROC(RMSUB,RS,RMPRI) ;
N RMDAT,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
N RMST2,RMTY,RM6,RM11,RMIT2,RMII,I,J,K,RMIDES,RMINS,RM11DA
I $G(RMPRI)="*" D ALL
D HCPC
;
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
..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)
...I $G(RMPRI)'="*",'$D(RMPRI(I)) Q
...Q:(RMST2'=RS)!(RMIT2'=J)!(RMTY'=1)
...S ^TMP($J,RMSUB,I,J,1,1)="^^^^"_RMIDES
;EXIT
Q
;
ALL ;process all HCPCS 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
HCPC ;process certain HCPCS
S I="" F S I=$O(RMPRI(I)) Q:I="" F J=0:0 S J=$O(^RMPR(661.7,"B",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 RMUNI=""
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) RMUNI=$$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))
I $G(RM11),$D(^RMPR(661.11,RM11,0)) S RMSO=$P(^RMPR(661.11,RM11,0),U,5),RMIDES=$P(^RMPR(661.11,RM11,0),U,3)
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,RMHC,RMHI,RMDT,RMLO)=RMPRT_"^"_RMUNI_"^"_RMSO
S ^TMP($J,"RMTMP",RMHC,RMHI)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPI01 5535 printed Sep 23, 2025@20:12:05 Page 2
RMPRPI01 ;HINCIO/ODJ - PIP Report APIs ;9/18/02 15:13
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ;
+3 QUIT
+4 ;
+5 ;***** HBAL - returns a ^TMP array structured as follows:-
+6 ; ^TMP($J,N,H,I,D,S,L)=data (^ delimiter)
+7 ;
+8 ; where N = ^TMP array name (eg. RMPRPI01)
+9 ; H = HCPCS code (eg. L5000)
+10 ; I = Item number (eg. 1)
+11 ; D = full FM date (eg. 3010309.135415)
+12 ; S = Source (C - comercial, V - VA)
+13 ; L = Location ien (ptr. ^RMPR(661.5,)
+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 ; RMPRHCPC - Array of HCPCS codes, or * for all HCPCS.
+27 ;
+28 ; Outputs:
+29 ; RMPRERR - 0 if no errors, +ve int. if errors
+30 ; ^TMP - (see above)
+31 ;
HBAL(RMPRNM,RMPRSTN,RMPRHCPC) ;
+1 NEW RMPRERR,RMPRH,RMPR,RMPROLD,RMPREOF,RMPRE,RMPRT,RMPR6E,RMPR11E,RMPR6I
+2 NEW RMPREI,RMPR4
+3 SET RMPRERR=0
+4 IF $GET(RMPRNM)=""
SET RMPRNM="RMPRPI01"
+5 IF $GET(RMPRSTN)=""
SET RMPRERR=1
GOTO HBALX
+6 IF '$DATA(RMPRHCPC)
SET RMPRHCPC="*"
+7 KILL ^TMP($JOB,RMPRNM)
+8 SET RMPR("STATION")=RMPRSTN
+9 IF $GET(RMPRHCPC)="*"
GOTO HBAL2
+10 SET RMPRH=""
HBAL1 SET RMPRH=$ORDER(RMPRHCPC(RMPRH))
+1 IF RMPRH=""
GOTO HBALX
+2 KILL RMPR
+3 SET RMPR("STATION")=RMPRSTN
+4 SET RMPR("HCPCS")=RMPRH
HBAL2 SET RMPRERR=$$NEXT^RMPRPIXE(.RMPR,"XSHIDS","",1,.RMPROLD,.RMPREOF)
+1 IF RMPRERR
GOTO HBALX
+2 IF RMPREOF
GOTO HBALX
+3 IF $GET(RMPRHCPC)'="*"
IF RMPROLD("HCPCS")'=RMPR("HCPCS")
GOTO HBAL1
+4 IF RMPROLD("STATION")'=RMPR("STATION")
if $GET(RMPRHCPC)="*"
GOTO HBAL2
GOTO HBAL1
+5 KILL RMPRE
MERGE RMPRE=RMPR
+6 SET RMPRERR=$$GET^RMPRPIX7(.RMPRE)
+7 IF RMPRERR
GOTO HBALX
+8 KILL RMPREI
SET RMPRERR=$$ETOI^RMPRPIX7(.RMPRE,.RMPREI)
+9 IF RMPRERR
GOTO HBALX
+10 KILL RMPR6E
+11 SET RMPR6E("HCPCS")=RMPR("HCPCS")
+12 SET RMPR6E("ITEM")=RMPR("ITEM")
+13 SET RMPR6E("DATE&TIME")=RMPR("DATE&TIME")
+14 SET RMPRERR=$$GET^RMPRPIX6(.RMPR6E)
+15 KILL RMPR11E
+16 SET RMPR11E("HCPCS")=RMPR("HCPCS")
+17 SET RMPR11E("ITEM")=RMPR("ITEM")
+18 SET RMPR11E("STATION")=RMPR("STATION")
+19 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11E)
+20 IF RMPRERR
GOTO HBALX
+21 KILL RMPR11I
+22 SET RMPRERR=$$ETOI^RMPRPIX1(.RMPR11E,.RMPR11I)
+23 IF RMPRERR
GOTO HBALX
+24 SET RMPRT=""
+25 SET $PIECE(RMPRT,"^",1)=RMPRE("QUANTITY")
+26 SET $PIECE(RMPRT,"^",2)=RMPRE("VALUE")
+27 IF +RMPRE("QUANTITY")
Begin DoDot:1
+28 SET $PIECE(RMPRT,"^",3)=$JUSTIFY(RMPRE("VALUE")/RMPRE("QUANTITY"),0,2)
+29 QUIT
End DoDot:1
+30 SET $PIECE(RMPRT,"^",4)=RMPR6E("VENDOR")
+31 SET $PIECE(RMPRT,"^",5)=RMPR11E("DESCRIPTION")
+32 SET $PIECE(RMPRT,"^",6)=RMPRE("LOCATION")
+33 KILL RMPR4
+34 SET RMPR4("IEN")=$ORDER(^RMPR(661.4,"ASLHI",RMPR11I("STATION"),RMPREI("LOCATION"),RMPR11I("HCPCS"),RMPR11I("ITEM"),""))
+35 ;next line added
+36 if RMPR4("IEN")=""
GOTO HBAL2
+37 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4)
+38 SET $PIECE(RMPRT,"^",7)=RMPR4("RE-ORDER QTY")
+39 SET ^TMP($JOB,RMPRNM,RMPR("HCPCS"),RMPR("ITEM"),RMPR("DATE&TIME"),RMPR11I("SOURCE"),RMPREI("LOCATION"))=RMPRT
+40 GOTO HBAL2
HBALX 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,RMII,I,J,K,RMIDES,RMINS,RM11DA
+3 IF $GET(RMPRI)="*"
DO ALL
+4 DO HCPC
+5 ;
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 SET RM11=$GET(^RMPR(661.11,K,0))
+6 if RM11=""
QUIT
+7 if $DATA(^TMP($JOB,"RMTMP",I,J))
QUIT
+8 SET RMIDES=$PIECE(RM11,U,3)
+9 if ($PIECE(RM11,U,9))=1
QUIT
+10 ;check what location this HCCPS/ITEM belongs to previously.
+11 FOR RMII=0:0
SET RMII=$ORDER(^RMPR(661.6,"B",I,RMII))
if RMII'>0
QUIT
Begin DoDot:3
+12 if '$DATA(^RMPR(661.6,RMII,0))
QUIT
+13 SET RM6=$GET(^RMPR(661.6,RMII,0))
SET RMIT2=$PIECE(RM6,U,11)
+14 SET RMTY=$PIECE(RM6,U,4)
SET RMST2=$PIECE(RM6,U,13)
+15 IF $GET(RMPRI)'="*"
IF '$DATA(RMPRI(I))
QUIT
+16 if (RMST2'=RS)!(RMIT2'=J)!(RMTY'=1)
QUIT
+17 SET ^TMP($JOB,RMSUB,I,J,1,1)="^^^^"_RMIDES
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;EXIT
+19 QUIT
+20 ;
ALL ;process all HCPCS 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
HCPC ;process certain HCPCS
+1 SET I=""
FOR
SET I=$ORDER(RMPRI(I))
if I=""
QUIT
FOR J=0:0
SET J=$ORDER(^RMPR(661.7,"B",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 RMUNI=""
+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 RMUNI=$$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)
IF $DATA(^RMPR(661.11,RM11,0))
SET RMSO=$PIECE(^RMPR(661.11,RM11,0),U,5)
SET RMIDES=$PIECE(^RMPR(661.11,RM11,0),U,3)
+22 SET RM4=$ORDER(^RMPR(661.4,"ASLHI",RS,RMLO,RMHC,RMHI,0))
+23 IF $GET(RM4)
IF $DATA(^RMPR(661.4,RM4,0))
SET RMRO=$PIECE(^RMPR(661.4,RM4,0),U,4)
+24 SET RMHCIEN=$ORDER(^RMPR(661.1,"B",RMHC,0))
+25 IF RMHCIEN
IF $DATA(^RMPR(661.1,RMHCIEN,0))
SET RMHDES=$PIECE(^RMPR(661.1,RMHCIEN,0),U,2)
+26 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
+27 if RMHC'=$PIECE(RM6,U,1)
QUIT
+28 IF (RMHC=$PIECE(RM6,U,1))
IF (RMSE=$PIECE(RM6,U,3))
SET RMV=$PIECE(RM6,U,12)
+29 if $GET(RMV)
SET RMVEN=$$GETVEN^RMPRPIU0(RMV)
End DoDot:1
+30 SET RMPRT=RMQU_"^"_RMVA_"^"_RMUC_"^"_RMVEN_"^"_RMIDES_"^"_RMLOC_"^"_RMRO
+31 SET ^TMP($JOB,RMSUB,RMHC,RMHI,RMDT,RMLO)=RMPRT_"^"_RMUNI_"^"_RMSO
+32 SET ^TMP($JOB,"RMTMP",RMHC,RMHI)=""
+33 QUIT
