RMPR5HQH ;HCIOFO/RVD - HCPCS USAGE REPORT ; 15 AUG 00
;;3.0;PROSTHETICS;**51**;Feb 09, 1996
;
DQ1 ;print PIP Report
;$O the ^TMP( global for all the records
;print all records based on the sort criteria given.
I IOST["C-" W @IOF
;
F RST=0:0 S RST=$O(^TMP($J,R5,RST)) Q:RST'>0 S RSTN=$$STN^RMPR5HQL(RST),RPR=0 F RI=0:0 S RI=$O(^TMP($J,R5,RST,RI)) Q:$G(RFL) Q:RI'>0 D
.D:RPR=0 HDRH
.S RNPGRP=RMARRAY(RI)
.S RJ=""
.F S RJ=$O(^TMP($J,R5,RST,RI,RJ)) Q:$G(RFL) D:(RLINE'="")&(RLINE'=RJ) SUML1^RMPR5HQ2 Q:RJ="" D
..S RLINE=RJ,RNPLINE=$$NPLIN^RMPR5HQ5(RJ)
..I RGCNT=0 S RGCNT=RGCNT+1
..S RK="" F S RK=$O(^TMP($J,R5,RST,RI,RJ,RK)) Q:$G(RFL) D:(RHCPC'="")&(RHCPC'=RK)&(RLCNT'=0) SUMH1 Q:RK="" D
...S RHCPC=RK
...S RL=""
...F S RL=$O(^TMP($J,R5,RST,RI,RJ,RK,RL)) Q:$G(RFL)!(RL="") D
....S RHCPC=$P(RK,"/",1)
....S RMHCDA=$P(RK,"/",2)
....S RNPITEM=$P($G(^RMPR(661.1,RMHCDA,0)),U,2)
....I RLCNT=0 D GLN1
....S RLCNT=RLCNT+1
....S RDAT=^TMP($J,R5,RST,RI,RJ,RK,RL)
....S RMVA=$P(RDAT,U,1)
....S RMCOM=$P(RDAT,U,2)
....S RMUSE=$P(RDAT,U,3)
....S RMISU=$P(RDAT,U,4)
....S RMISN=$P(RDAT,U,5)
....S RMAVEN=$P(RDAT,U,6)
....S RMDLEN=$P(RDAT,U,7)
....S RMQOHU=$P(RDAT,U,8)
....S RMQOHN=$P(RDAT,U,9)
....S RMVALU=$P(RDAT,U,10)
....S RMVALN=$P(RDAT,U,11)
....S RMAVEU=$P(RDAT,U,12)
....S RMDLEU=$P(RDAT,U,13)
....;total for HCPCS
....S RMTVAH=RMTVAH+RMVA
....S RMTCOMH=RMTCOMH+RMCOM
....S RMTISUH=RMTISUH+RMISU
....S RMTISNH=RMTISNH+RMISN
....I (RMCOM'=""),$G(RMCOM) S RTUSEHC=RTUSEHC+RMCOM
....I (RMVA'=""),$G(RMVA) S RTUSEHA=RTUSEHA+RMVA
....S RMTQOHUH=RMTQOHUH+RMQOHU
....S RMTQOHNH=RMTQOHNH+RMQOHN
....S RMTVALUH=RMTVALUH+RMVALU
....S RMTVALNH=RMTVALNH+RMVALN
....S RMGTOU=RMGTOU+RMVALU
....S RMGTON=RMGTON+RMVALN
....S RMGTIU=RMGTIU+RMISU
....S RMGTIN=RMGTIN+RMISN
....;total for line item
....S RMTVAL=RMTVAL+RMVA
....S RMTCOML=RMTCOML+RMCOM
....;S RMTUSEL=RMTUSEL+RMUSE
....S:RMVA'="" RMTUSELU=RMTUSELU+RMVA
....S:RMCOM'="" RMTUSELN=RMTUSELN+RMCOM
....S RMTISUL=RMTISUL+RMISU
....S RMTAVELU=RMTAVELU+RMAVEU
....S RMTAVELN=RMTAVELN+RMAVEN
....S RMTDLEL=RMTDLEL+RMDLEU+RMDLEN
....S RMTISNL=RMTISNL+RMISN
....S RMTQOHUL=RMTQOHUL+RMQOHU
....S RMTQOHNL=RMTQOHNL+RMQOHN
....S RMTVALUL=RMTVALUL+RMVALU
....S RMTVALNL=RMTVALNL+RMVALN
....S (RPRINT,RPR)=1
Q
;
HDRH ;print heading.
Q:$G(RFL)
S RMPAGE=RMPAGE+1
W !,"PROSTHETIC INVENTORY HCPCS SUMMARY REPORT",?50,"Run Date: ",RMRDATE,?100,"Page: ",RMPAGE
W !,"STATION: ",$E(RSTN,1,20)
W ?32,RMBD," - ",RMED," [ ",RMCALDAY," calendar days ]"
Q
;
GLN1 ;print NPPD GROUP and LINE header.
Q:$G(RFL)
W !!,RJ," ",RNPLINE," [ ",RNPGRP," ]"
D LBL1^RMPR5HQ2
Q
;
SUMH1 ;
Q:$G(RFL)
S:$G(RTUSEHC) RTAVEHC=RTUSEHC/RMCALDAY
S:$G(RTAVEHC) RTDLEHC=RMTQOHNH/RTAVEHC
S:$G(RTUSEHA) RTAVEHA=RTUSEHA/RMCALDAY
S:$G(RTAVEHA) RTDLEHA=RMTQOHUH/RTAVEHA
S RTDLEHA=$S(RTDLEHA>999:">999",1:$J(RTDLEHA,6,0))
S RTDLEHC=$S(RTDLEHC>999:">999",1:$J(RTDLEHC,6,0))
S:RMTQOHNH=0 RTDLEHC=""
S:RMTQOHUH=0 RTDLEHA=""
S:(RMTQOHNH>0)&(RMTCOMH<1) RTDLEHC=">"_RMCALDAY
S:(RMTQOHUH>0)&(RMTVAH<1) RTDLEHA=">"_RMCALDAY
S RMTAVEL=RTAVEHA+RTAVEHC
;next 2 lines for used:
W !,RHCPC,?10,$E(RNPITEM,1,10),"(Used)",?26,$J(RMTVAH,5),?34,$J($FN(RMTISUH,",",2),6),?40,"|",?59,"|",?60,$J(RTUSEHA,5),?67,"|",?71,$J(RTAVEHA,5,2),?78,"|"
W ?81,$J(RMTQOHUH,5),?94,"|",?97,$J(RTDLEHA,6),?103,"|",?104,$J($FN(RMTVALUH,",",2),11)
;next 2 lines for new:
W !,RHCPC,?10,$E(RNPITEM,1,10),"(New)",?40,"|",?41,$J(RMTCOMH,4),?49,$J($FN(RMTISNH,",",2),9),?59,"|",?60,$J(RTUSEHC,5),?67,"|",?71,$J(RTAVEHC,5,2),?78,"|"
W ?87,$J(RMTQOHNH,6),?94,"|",?97,$J(RTDLEHC,6),?103,"|",?116,$J($FN(RMTVALNH,",",2),11)
S RPR=1
I $Y+8>IOSL,IOST["C-" K DIR S DIR(0)="E" D ^DIR S:+Y'>0 RFL=1 Q:+Y'>0 W @IOF D HDRH,LBL1^RMPR5HQ2
I $Y+8>IOSL,IOST'["C-" W @IOF D HDRH,LBL1^RMPR5HQ2
S (RMTVAH,RMTISUH,RMTCOMH,RMTISNH,RMTUSEH,RMTAVEH,RMTQOHUH,RMTQOHNH,RMTVALUH,RMTVALNH,RHCNT)=0
S (RTUSEHA,RTUSEHC,RTDLEHA,RTDLEHC,RTAVEHA,RTAVEHC)=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5HQH 4094 printed Sep 23, 2025@20:09:18 Page 2
RMPR5HQH ;HCIOFO/RVD - HCPCS USAGE REPORT ; 15 AUG 00
+1 ;;3.0;PROSTHETICS;**51**;Feb 09, 1996
+2 ;
DQ1 ;print PIP Report
+1 ;$O the ^TMP( global for all the records
+2 ;print all records based on the sort criteria given.
+3 IF IOST["C-"
WRITE @IOF
+4 ;
+5 FOR RST=0:0
SET RST=$ORDER(^TMP($JOB,R5,RST))
if RST'>0
QUIT
SET RSTN=$$STN^RMPR5HQL(RST)
SET RPR=0
FOR RI=0:0
SET RI=$ORDER(^TMP($JOB,R5,RST,RI))
if $GET(RFL)
QUIT
if RI'>0
QUIT
Begin DoDot:1
+6 if RPR=0
DO HDRH
+7 SET RNPGRP=RMARRAY(RI)
+8 SET RJ=""
+9 FOR
SET RJ=$ORDER(^TMP($JOB,R5,RST,RI,RJ))
if $GET(RFL)
QUIT
if (RLINE'="")&(RLINE'=RJ)
DO SUML1^RMPR5HQ2
if RJ=""
QUIT
Begin DoDot:2
+10 SET RLINE=RJ
SET RNPLINE=$$NPLIN^RMPR5HQ5(RJ)
+11 IF RGCNT=0
SET RGCNT=RGCNT+1
+12 SET RK=""
FOR
SET RK=$ORDER(^TMP($JOB,R5,RST,RI,RJ,RK))
if $GET(RFL)
QUIT
if (RHCPC'="")&(RHCPC'=RK)&(RLCNT'=0)
DO SUMH1
if RK=""
QUIT
Begin DoDot:3
+13 SET RHCPC=RK
+14 SET RL=""
+15 FOR
SET RL=$ORDER(^TMP($JOB,R5,RST,RI,RJ,RK,RL))
if $GET(RFL)!(RL="")
QUIT
Begin DoDot:4
+16 SET RHCPC=$PIECE(RK,"/",1)
+17 SET RMHCDA=$PIECE(RK,"/",2)
+18 SET RNPITEM=$PIECE($GET(^RMPR(661.1,RMHCDA,0)),U,2)
+19 IF RLCNT=0
DO GLN1
+20 SET RLCNT=RLCNT+1
+21 SET RDAT=^TMP($JOB,R5,RST,RI,RJ,RK,RL)
+22 SET RMVA=$PIECE(RDAT,U,1)
+23 SET RMCOM=$PIECE(RDAT,U,2)
+24 SET RMUSE=$PIECE(RDAT,U,3)
+25 SET RMISU=$PIECE(RDAT,U,4)
+26 SET RMISN=$PIECE(RDAT,U,5)
+27 SET RMAVEN=$PIECE(RDAT,U,6)
+28 SET RMDLEN=$PIECE(RDAT,U,7)
+29 SET RMQOHU=$PIECE(RDAT,U,8)
+30 SET RMQOHN=$PIECE(RDAT,U,9)
+31 SET RMVALU=$PIECE(RDAT,U,10)
+32 SET RMVALN=$PIECE(RDAT,U,11)
+33 SET RMAVEU=$PIECE(RDAT,U,12)
+34 SET RMDLEU=$PIECE(RDAT,U,13)
+35 ;total for HCPCS
+36 SET RMTVAH=RMTVAH+RMVA
+37 SET RMTCOMH=RMTCOMH+RMCOM
+38 SET RMTISUH=RMTISUH+RMISU
+39 SET RMTISNH=RMTISNH+RMISN
+40 IF (RMCOM'="")
IF $GET(RMCOM)
SET RTUSEHC=RTUSEHC+RMCOM
+41 IF (RMVA'="")
IF $GET(RMVA)
SET RTUSEHA=RTUSEHA+RMVA
+42 SET RMTQOHUH=RMTQOHUH+RMQOHU
+43 SET RMTQOHNH=RMTQOHNH+RMQOHN
+44 SET RMTVALUH=RMTVALUH+RMVALU
+45 SET RMTVALNH=RMTVALNH+RMVALN
+46 SET RMGTOU=RMGTOU+RMVALU
+47 SET RMGTON=RMGTON+RMVALN
+48 SET RMGTIU=RMGTIU+RMISU
+49 SET RMGTIN=RMGTIN+RMISN
+50 ;total for line item
+51 SET RMTVAL=RMTVAL+RMVA
+52 SET RMTCOML=RMTCOML+RMCOM
+53 ;S RMTUSEL=RMTUSEL+RMUSE
+54 if RMVA'=""
SET RMTUSELU=RMTUSELU+RMVA
+55 if RMCOM'=""
SET RMTUSELN=RMTUSELN+RMCOM
+56 SET RMTISUL=RMTISUL+RMISU
+57 SET RMTAVELU=RMTAVELU+RMAVEU
+58 SET RMTAVELN=RMTAVELN+RMAVEN
+59 SET RMTDLEL=RMTDLEL+RMDLEU+RMDLEN
+60 SET RMTISNL=RMTISNL+RMISN
+61 SET RMTQOHUL=RMTQOHUL+RMQOHU
+62 SET RMTQOHNL=RMTQOHNL+RMQOHN
+63 SET RMTVALUL=RMTVALUL+RMVALU
+64 SET RMTVALNL=RMTVALNL+RMVALN
+65 SET (RPRINT,RPR)=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+66 QUIT
+67 ;
HDRH ;print heading.
+1 if $GET(RFL)
QUIT
+2 SET RMPAGE=RMPAGE+1
+3 WRITE !,"PROSTHETIC INVENTORY HCPCS SUMMARY REPORT",?50,"Run Date: ",RMRDATE,?100,"Page: ",RMPAGE
+4 WRITE !,"STATION: ",$EXTRACT(RSTN,1,20)
+5 WRITE ?32,RMBD," - ",RMED," [ ",RMCALDAY," calendar days ]"
+6 QUIT
+7 ;
GLN1 ;print NPPD GROUP and LINE header.
+1 if $GET(RFL)
QUIT
+2 WRITE !!,RJ," ",RNPLINE," [ ",RNPGRP," ]"
+3 DO LBL1^RMPR5HQ2
+4 QUIT
+5 ;
SUMH1 ;
+1 if $GET(RFL)
QUIT
+2 if $GET(RTUSEHC)
SET RTAVEHC=RTUSEHC/RMCALDAY
+3 if $GET(RTAVEHC)
SET RTDLEHC=RMTQOHNH/RTAVEHC
+4 if $GET(RTUSEHA)
SET RTAVEHA=RTUSEHA/RMCALDAY
+5 if $GET(RTAVEHA)
SET RTDLEHA=RMTQOHUH/RTAVEHA
+6 SET RTDLEHA=$SELECT(RTDLEHA>999:">999",1:$JUSTIFY(RTDLEHA,6,0))
+7 SET RTDLEHC=$SELECT(RTDLEHC>999:">999",1:$JUSTIFY(RTDLEHC,6,0))
+8 if RMTQOHNH=0
SET RTDLEHC=""
+9 if RMTQOHUH=0
SET RTDLEHA=""
+10 if (RMTQOHNH>0)&(RMTCOMH<1)
SET RTDLEHC=">"_RMCALDAY
+11 if (RMTQOHUH>0)&(RMTVAH<1)
SET RTDLEHA=">"_RMCALDAY
+12 SET RMTAVEL=RTAVEHA+RTAVEHC
+13 ;next 2 lines for used:
+14 WRITE !,RHCPC,?10,$EXTRACT(RNPITEM,1,10),"(Used)",?26,$JUSTIFY(RMTVAH,5),?34,$JUSTIFY($FNUMBER(RMTISUH,",",2),6),?40,"|",?59,"|",?60,$JUSTIFY(RTUSEHA,5),?67,"|",?71,$JUSTIFY(RTAVEHA,5,2),?78,"|"
+15 WRITE ?81,$JUSTIFY(RMTQOHUH,5),?94,"|",?97,$JUSTIFY(RTDLEHA,6),?103,"|",?104,$JUSTIFY($FNUMBER(RMTVALUH,",",2),11)
+16 ;next 2 lines for new:
+17 WRITE !,RHCPC,?10,$EXTRACT(RNPITEM,1,10),"(New)",?40,"|",?41,$JUSTIFY(RMTCOMH,4),?49,$JUSTIFY($FNUMBER(RMTISNH,",",2),9),?59,"|",?60,$JUSTIFY(RTUSEHC,5),?67,"|",?71,$JUSTIFY(RTAVEHC,5,2),?78,"|"
+18 WRITE ?87,$JUSTIFY(RMTQOHNH,6),?94,"|",?97,$JUSTIFY(RTDLEHC,6),?103,"|",?116,$JUSTIFY($FNUMBER(RMTVALNH,",",2),11)
+19 SET RPR=1
+20 IF $Y+8>IOSL
IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
if +Y'>0
SET RFL=1
if +Y'>0
QUIT
WRITE @IOF
DO HDRH
DO LBL1^RMPR5HQ2
+21 IF $Y+8>IOSL
IF IOST'["C-"
WRITE @IOF
DO HDRH
DO LBL1^RMPR5HQ2
+22 SET (RMTVAH,RMTISUH,RMTCOMH,RMTISNH,RMTUSEH,RMTAVEH,RMTQOHUH,RMTQOHNH,RMTVALUH,RMTVALNH,RHCNT)=0
+23 SET (RTUSEHA,RTUSEHC,RTDLEHA,RTDLEHC,RTAVEHA,RTAVEHC)=0
+24 QUIT
