RMPRPI06 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/8/05 11:36
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
; DBIA #10090 - Read Access to entire file #4.
; DBIA #10096 - Access to all %ZOSF nodes.
;
D DIV4^RMPRSIT I $D(Y),(Y<0) Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
;
EN K ^TMP($J),RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS
S DIC="^RMPR(661.1,",DIC(0)="AEQM"
S DIC("S")="I $D(^RMPR(661.1,+Y,0))"
;
EN1 ;
S RAS1="Enter 'ALL' for all HCPCS or 'RETURN' "
S RAS2="to select individual HCPCS: "
W !!,RAS1,RAS2
R RMENTER:DTIME G:$D(DTOUT)!$D(DUOUT)!(RMENTER="^") EXIT1
G:RMENTER["?" EN1
S X=RMENTER X ^%ZOSF("UPPERCASE") S RMENTER=Y
I RMENTER="ALL" S RMPRI="*" G CONT
;
SEL W ! F RML=1:1 S DIC("A")="Select HCPCS "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
.S RMI=$P(^RMPR(661.1,+Y,0),U,1)
.I $D(RMPRI(RMI)) W $C(7)," ??",?40,"..Duplicate HCPCS" S RML=RML-1 Q
.S RMPRI(RMI)=+Y
;
CONT G:'$D(RMPRI) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1
I '$D(IO("Q")) U IO G PRINT
K IO("Q") S ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY"
S ZTRTN="PRINT^RMPRPI06",ZTIO=ION,ZTSAVE("RMPRI(")="",ZTSAVE("RMPRI")=""
S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
;
PRINT I $E(IOST)["C" W !!,"Processing report......."
S RMSUB="RM",RS=RMPR("STA")
;call API
;input variables:
; RMSUB = 'RM' subscript
; RS = rmpr("sta")
; rmpri = an array of Location
;S RMCHK=$$HBAL^RMPRPI01(RMSUB,RS,.RMPRI)
;I RMCHK W !!,"*** Error in API RMPRPI01 !!!" G EXIT
D PROC^RMPRPI01(RMSUB,RS,.RMPRI)
;
S RMPAGE=1,(RMTOBAL,RMPREND)=0
I '$D(^TMP($J,"RM")) D NONE G EXIT
W:$E(IOST)["C" @IOF
D HEAD,WRI
I RMSUF D TOTAL W !,"<End of Report>" G EXIT
;
;write/print report
;rh = HCPCS
;rl = Location
;j = Item
;k = Date
;
WRI S RH="",(RMPREND,RMSUF)=0 D HEAD1
F S RH=$O(^TMP($J,"RM",RH)) Q:(RH="")!(RMPREND) D:RMSUF TOTAL S (RVA,RTO)=0,RHO=RH K RMPRFLG S RI=0 F S RI=$O(^TMP($J,"RM",RH,RI)) Q:(RI'>0)!(RMPREND) S J=0 D
.F S J=$O(^TMP($J,"RM",RH,RI,J)) Q:(J'>0)!(RMPREND) S RMPRLOCN="" F S RMPRLOCN=$O(^TMP($J,"RM",RH,RI,J,RMPRLOCN)) Q:(RMPRLOCN="")!(RMPREND) D
..S RMAST="",RMTMP=^TMP($J,"RM",RH,RI,J,RMPRLOCN),RMQTY=$P(RMTMP,U,1)
..S RMVAL=$P(RMTMP,U,2),RMCOS=$P(RMTMP,U,3),RMVEN=$P(RMTMP,U,4)_" "
..S RMIDE=$P(RMTMP,U,5),RMLOC=$P(RMTMP,U,6),RMUNI=$P(RMTMP,U,8)
..;S RMDAT=$E(J,4,5)_"/"_$E(J,6,7)_"/"_$E(J,2,3)
..S RMROR=$P(RMTMP,U,7)
..S RMSOR=$P(RMTMP,U,9)
..S:RMROR>RMQTY RMAST="*"
..S:RMQTY="" RMQTY=0
..S RTO=RTO+RMQTY,RVA=RVA+RMVAL
..S RMITEM=RI,RMHCPC=RH,RMSUF=1
..S RMIDE=$E(RMIDE,1,17)
..W !,RH_"-"_RI,?10,RMIDE,?28,RMSOR,?31,$E(RMLOC,1,8),?40,$E(RMVEN,1,7)
..W ?46,$J(RMROR,4),?52,RMUNI,?57,$J(RMQTY,4),?61,$J(RMCOS,8,2),?69,$J($FN(RMVAL,",",2),10)
..S RMPRFLG=1
..I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q
..I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 K RMPRFLG Q
Q
;
TOTAL W !,?56,"=======================",!,?31,"Totals for ",RHO," = "
W ?54,$J(RTO,7),?69,$J($FN(RVA,",",2),10),!,RMPR("L")
S RMSUF=0,RTO=0
Q
;
HEAD W !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***"
W ?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT
W ?30,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,20)
S RMPAGE=RMPAGE+1
Q
;
HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD
I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD
W !,RMPR("L")
W !,?47,"RE-",?52,"UNIT"
W !,?46,"ORDER",?53,"OF",?65,"UNIT",?74,"TOTAL"
W !,"HCPCS",?10,"ITEM",?26,"SRC",?30,"LOCATION",?39,"VENDOR"
W ?46,"LEVEL",?52,"ISSUE",?59,"QTY",?65,"COST",?74,"VALUE"
W !,"-----",?10,"----",?26,"---",?30,"--------",?39,"------"
W ?46,"-----",?52,"-----",?59,"---",?65,"----",?73,"------"
S RMPRFLG=1
Q
;
EXIT I $E(IOST)["C",'RMPREND W ! S DIR(0)="E" D ^DIR
;
EXIT1 D ^%ZISC
N RMPR,RMPRSITE D KILL^XUSCLEAN
K ^TMP($J)
Q
;
NONE ;
W:$E(IOST)["C" @IOF
D HEAD W !!,"NO DATA !!!!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPI06 4100 printed Apr 09, 2024@21:40:39 Page 2
RMPRPI06 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/8/05 11:36
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 ; DBIA #10090 - Read Access to entire file #4.
+3 ; DBIA #10096 - Access to all %ZOSF nodes.
+4 ;
+5 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
QUIT
+6 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+7 ;
EN KILL ^TMP($JOB),RMPRI,RMPRFLG
SET RMPREND=0
DO HOME^%ZIS
+1 SET DIC="^RMPR(661.1,"
SET DIC(0)="AEQM"
+2 SET DIC("S")="I $D(^RMPR(661.1,+Y,0))"
+3 ;
EN1 ;
+1 SET RAS1="Enter 'ALL' for all HCPCS or 'RETURN' "
+2 SET RAS2="to select individual HCPCS: "
+3 WRITE !!,RAS1,RAS2
+4 READ RMENTER:DTIME
if $DATA(DTOUT)!$DATA(DUOUT)!(RMENTER="^")
GOTO EXIT1
+5 if RMENTER["?"
GOTO EN1
+6 SET X=RMENTER
XECUTE ^%ZOSF("UPPERCASE")
SET RMENTER=Y
+7 IF RMENTER="ALL"
SET RMPRI="*"
GOTO CONT
+8 ;
SEL WRITE !
FOR RML=1:1
SET DIC("A")="Select HCPCS "_RML_": "
DO ^DIC
if $DATA(DTOUT)!(X["^")!(X=""&(RML=1))
GOTO EXIT1
if X=""
QUIT
Begin DoDot:1
+1 SET RMI=$PIECE(^RMPR(661.1,+Y,0),U,1)
+2 IF $DATA(RMPRI(RMI))
WRITE $CHAR(7)," ??",?40,"..Duplicate HCPCS"
SET RML=RML-1
QUIT
+3 SET RMPRI(RMI)=+Y
End DoDot:1
+4 ;
CONT if '$DATA(RMPRI)
GOTO EXIT1
SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT1
+1 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+2 KILL IO("Q")
SET ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY"
+3 SET ZTRTN="PRINT^RMPRPI06"
SET ZTIO=ION
SET ZTSAVE("RMPRI(")=""
SET ZTSAVE("RMPRI")=""
+4 SET ZTSAVE("RMPR(""STA"")")=""
SET ZTSAVE("RMDAT")=""
SET ZTSAVE("RMPR(")=""
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT
+6 ;
PRINT IF $EXTRACT(IOST)["C"
WRITE !!,"Processing report......."
+1 SET RMSUB="RM"
SET RS=RMPR("STA")
+2 ;call API
+3 ;input variables:
+4 ; RMSUB = 'RM' subscript
+5 ; RS = rmpr("sta")
+6 ; rmpri = an array of Location
+7 ;S RMCHK=$$HBAL^RMPRPI01(RMSUB,RS,.RMPRI)
+8 ;I RMCHK W !!,"*** Error in API RMPRPI01 !!!" G EXIT
+9 DO PROC^RMPRPI01(RMSUB,RS,.RMPRI)
+10 ;
+11 SET RMPAGE=1
SET (RMTOBAL,RMPREND)=0
+12 IF '$DATA(^TMP($JOB,"RM"))
DO NONE
GOTO EXIT
+13 if $EXTRACT(IOST)["C"
WRITE @IOF
+14 DO HEAD
DO WRI
+15 IF RMSUF
DO TOTAL
WRITE !,"<End of Report>"
GOTO EXIT
+16 ;
+17 ;write/print report
+18 ;rh = HCPCS
+19 ;rl = Location
+20 ;j = Item
+21 ;k = Date
+22 ;
WRI SET RH=""
SET (RMPREND,RMSUF)=0
DO HEAD1
+1 FOR
SET RH=$ORDER(^TMP($JOB,"RM",RH))
if (RH="")!(RMPREND)
QUIT
if RMSUF
DO TOTAL
SET (RVA,RTO)=0
SET RHO=RH
KILL RMPRFLG
SET RI=0
FOR
SET RI=$ORDER(^TMP($JOB,"RM",RH,RI))
if (RI'>0)!(RMPREND)
QUIT
SET J=0
Begin DoDot:1
+2 FOR
SET J=$ORDER(^TMP($JOB,"RM",RH,RI,J))
if (J'>0)!(RMPREND)
QUIT
SET RMPRLOCN=""
FOR
SET RMPRLOCN=$ORDER(^TMP($JOB,"RM",RH,RI,J,RMPRLOCN))
if (RMPRLOCN="")!(RMPREND)
QUIT
Begin DoDot:2
+3 SET RMAST=""
SET RMTMP=^TMP($JOB,"RM",RH,RI,J,RMPRLOCN)
SET RMQTY=$PIECE(RMTMP,U,1)
+4 SET RMVAL=$PIECE(RMTMP,U,2)
SET RMCOS=$PIECE(RMTMP,U,3)
SET RMVEN=$PIECE(RMTMP,U,4)_" "
+5 SET RMIDE=$PIECE(RMTMP,U,5)
SET RMLOC=$PIECE(RMTMP,U,6)
SET RMUNI=$PIECE(RMTMP,U,8)
+6 ;S RMDAT=$E(J,4,5)_"/"_$E(J,6,7)_"/"_$E(J,2,3)
+7 SET RMROR=$PIECE(RMTMP,U,7)
+8 SET RMSOR=$PIECE(RMTMP,U,9)
+9 if RMROR>RMQTY
SET RMAST="*"
+10 if RMQTY=""
SET RMQTY=0
+11 SET RTO=RTO+RMQTY
SET RVA=RVA+RMVAL
+12 SET RMITEM=RI
SET RMHCPC=RH
SET RMSUF=1
+13 SET RMIDE=$EXTRACT(RMIDE,1,17)
+14 WRITE !,RH_"-"_RI,?10,RMIDE,?28,RMSOR,?31,$EXTRACT(RMLOC,1,8),?40,$EXTRACT(RMVEN,1,7)
+15 WRITE ?46,$JUSTIFY(RMROR,4),?52,RMUNI,?57,$JUSTIFY(RMQTY,4),?61,$JUSTIFY(RMCOS,8,2),?69,$JUSTIFY($FNUMBER(RMVAL,",",2),10)
+16 SET RMPRFLG=1
+17 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!(Y=0)
SET RMPREND=1
if RMPREND
QUIT
WRITE @IOF
DO HEAD
DO HEAD1
QUIT
+18 IF $Y>(IOSL-6)
WRITE @IOF
DO HEAD
DO HEAD1
KILL RMPRFLG
QUIT
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
TOTAL WRITE !,?56,"=======================",!,?31,"Totals for ",RHO," = "
+1 WRITE ?54,$JUSTIFY(RTO,7),?69,$JUSTIFY($FNUMBER(RVA,",",2),10),!,RMPR("L")
+2 SET RMSUF=0
SET RTO=0
+3 QUIT
+4 ;
HEAD WRITE !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***"
+1 WRITE ?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT
+2 WRITE ?30,"station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,20)
+3 SET RMPAGE=RMPAGE+1
+4 QUIT
+5 ;
HEAD1 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!(Y=0)
SET RMPREND=1
if RMPREND
QUIT
WRITE @IOF
DO HEAD
+1 IF $EXTRACT(IOST)'["C"&($Y>(IOSL-6))
WRITE @IOF
DO HEAD
+2 WRITE !,RMPR("L")
+3 WRITE !,?47,"RE-",?52,"UNIT"
+4 WRITE !,?46,"ORDER",?53,"OF",?65,"UNIT",?74,"TOTAL"
+5 WRITE !,"HCPCS",?10,"ITEM",?26,"SRC",?30,"LOCATION",?39,"VENDOR"
+6 WRITE ?46,"LEVEL",?52,"ISSUE",?59,"QTY",?65,"COST",?74,"VALUE"
+7 WRITE !,"-----",?10,"----",?26,"---",?30,"--------",?39,"------"
+8 WRITE ?46,"-----",?52,"-----",?59,"---",?65,"----",?73,"------"
+9 SET RMPRFLG=1
+10 QUIT
+11 ;
EXIT IF $EXTRACT(IOST)["C"
IF 'RMPREND
WRITE !
SET DIR(0)="E"
DO ^DIR
+1 ;
EXIT1 DO ^%ZISC
+1 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+2 KILL ^TMP($JOB)
+3 QUIT
+4 ;
NONE ;
+1 if $EXTRACT(IOST)["C"
WRITE @IOF
+2 DO HEAD
WRITE !!,"NO DATA !!!!!"
+3 QUIT
