RMPR5HQG ;HCIOFO/RVD - NPPD GROUP USAGE REPORT ; 15 AUG 00
;;3.0;PROSTHETICS;**51**;Feb 09, 1996
;
; HNC - added grand totals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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) D:(RGRP'="")&(RGRP'=RI) SUMG1 Q:RI'>0 D
.D:RPR=0 HDRG
.S RGRP=RI
.S RNPGRP=RMARRAY(RI)
.S RJ=""
.F S RJ=$O(^TMP($J,R5,RST,RI,RJ)) Q:$G(RFL) Q:RJ="" D
..S RLINE=RJ,RNPLINE=$$NPLIN^RMPR5HQ5(RJ)
..S RK="" F S RK=$O(^TMP($J,R5,RST,RI,RJ,RK)) Q:$G(RFL)!(RK="") D
...S RL=""
...F S RL=$O(^TMP($J,R5,RST,RI,RJ,RK,RL)) Q:$G(RFL)!(RL="") D
....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)
....S RMGISUG=RMGISUG+RMISU
....S RMGISNG=RMGISNG+RMISN
....;
....S RMGTIU=RMGTIU+RMISU
....S RMGTIN=RMGTIN+RMISN
....;
....S RMGTOU=RMGTOU+RMVALU
....S RMGTON=RMGTON+RMVALN
....;total for GROUP
....I (RMCOM'=""),$G(RMCOM) S RTUSEGC=RTUSEGC+RMCOM
....I (RMVA'=""),$G(RMVA) S RTUSEGA=RTUSEGA+RMVA
....S RMTVAG=RMTVAG+RMVA
....S RMTCOMG=RMTCOMG+RMCOM
....S RMTISUG=RMTISUG+RMISU
....S RMTISNG=RMTISNG+RMISN
....S RMTQOHUG=RMTQOHUG+RMQOHU
....S RMTQOHNG=RMTQOHNG+RMQOHN
....S RMTVALUG=RMTVALUG+RMVALU
....S RMTVALNG=RMTVALNG+RMVALN
....S (RPRINT,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 HDRG,LBL1^RMPR5HQ2
....I $Y+8>IOSL,IOST'["C-" W @IOF D HDRG,LBL1^RMPR5HQ2
I '$G(RPRINT) W !!,"No Records to Print !!" Q
Q:$G(RFL)
W !!,REQ
S RMGTOT=RMGTOU+RMGTON
W !!,?10,"GRAND TOTAL $ VALUE ISSUED (Used) = ",?38,"$",$J($FN(RMGISUG,",",2),10)
W ?80,"GRAND TOTAL $ VALUE ON-HAND (Used) = ",?115,"$",$J($FN(RMGTOU,",",2),12)
W !,?10,"GRAND TOTAL $ VALUE ISSUED (New) = ",?38,"$",$J($FN(RMGISNG,",",2),10)
W ?80,"GRAND TOTAL $ VALUE ON-HAND (New) = ",?115,"$",$J($FN(RMGTON,",",2),12)
;W !,?80,"GRAND TOTAL $ VALUE ON-HAND = ",?68,"$"_$J($FN(RMGTOT,",",2),12)
W !,"<End of Report>"
Q
;
HDRG ;print heading.
Q:$G(RFL)
S RMPAGE=RMPAGE+1
W !,"PROSTHETIC INVENTORY NPPD GROUP 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.
W !!,"ENTIRE SUMMARY"
D LBL1^RMPR5HQ2
Q
;
SUMG1 ;print summary total for NPPD GROUP
Q:$G(RFL)
W !,RLN
W !,RGRP," ",RNPGRP
S:$G(RTUSEGA) RTAVEGA=RTUSEGA/RMCALDAY
S:$G(RTUSEGC) RTAVEGC=RTUSEGC/RMCALDAY
S:$G(RTUSEGA) RTDLEGA=RMTQOHUG/RTAVEGA
S:$G(RTUSEGC) RTDLEGC=RMTQOHNG/RTAVEGC
S RTDLEGA=$S(RTDLEGA>999:">999",1:$J(RTDLEGA,5,0))
S RTDLEGC=$S(RTDLEGC>999:">999",1:$J(RTDLEGC,5,0))
S:RMTQOHNG=0 RTDLEGC=""
S:RMTQOHUG=0 RTDLEGA=""
S:(RMTQOHNG>0)&(RMTCOMG<1) RTDLEGC=">"_RMCALDAY
S:(RMTQOHUG>0)&(RMTVAG<1) RTDLEGA=">"_RMCALDAY
;next 2 lines for used:
W !,?5,"(Used)",?26,$J(RMTVAG,5),?34,$J($FN(RMTISUG,",",2),6),?40,"|",?59,"|",?60,$J(RTUSEGA,5),?67,"|",?71,$J(RTAVEGA,5,2),?78,"|"
W ?81,$J(RMTQOHUG,5),?94,"|",?97,$J(RTDLEGA,6),?103,"|",?104,$J($FN(RMTVALUG,",",2),11)
;next 2 lines for new:
W !,?5,"(New)",?40,"|",?41,$J(RMTCOMG,4),?49,$J($FN(RMTISNG,",",2),9),?59,"|",?60,$J(RTUSEGC,5),?67,"|",?71,$J(RTAVEGC,5,2),?78,"|"
W ?87,$J(RMTQOHNG,6),?94,"|",?97,$J(RTDLEGC,6),?103,"|",?116,$J($FN(RMTVALNG,",",2),11)
S (RMTVAG,RMTISUG,RMTCOMG,RMTISNG,RTUSEGA,RTUSEGC,RTAVEGA,RTAVEGC,RMTQOHUG,RMTQOHNG,RTDLEGA,RTDLEGC,RMTVALUG,RMTVALNG)=0
S (RNPGRP,RGRP)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5HQG 4063 printed Sep 23, 2025@20:09:17 Page 2
RMPR5HQG ;HCIOFO/RVD - NPPD GROUP USAGE REPORT ; 15 AUG 00
+1 ;;3.0;PROSTHETICS;**51**;Feb 09, 1996
+2 ;
+3 ; HNC - added grand totals
+4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 (RGRP'="")&(RGRP'=RI)
DO SUMG1
if RI'>0
QUIT
Begin DoDot:1
+6 if RPR=0
DO HDRG
+7 SET RGRP=RI
+8 SET RNPGRP=RMARRAY(RI)
+9 SET RJ=""
+10 FOR
SET RJ=$ORDER(^TMP($JOB,R5,RST,RI,RJ))
if $GET(RFL)
QUIT
if RJ=""
QUIT
Begin DoDot:2
+11 SET RLINE=RJ
SET RNPLINE=$$NPLIN^RMPR5HQ5(RJ)
+12 SET RK=""
FOR
SET RK=$ORDER(^TMP($JOB,R5,RST,RI,RJ,RK))
if $GET(RFL)!(RK="")
QUIT
Begin DoDot:3
+13 SET RL=""
+14 FOR
SET RL=$ORDER(^TMP($JOB,R5,RST,RI,RJ,RK,RL))
if $GET(RFL)!(RL="")
QUIT
Begin DoDot:4
+15 IF RLCNT=0
DO GLN1
+16 SET RLCNT=RLCNT+1
+17 SET RDAT=^TMP($JOB,R5,RST,RI,RJ,RK,RL)
+18 SET RMVA=$PIECE(RDAT,U,1)
+19 SET RMCOM=$PIECE(RDAT,U,2)
+20 SET RMUSE=$PIECE(RDAT,U,3)
+21 SET RMISU=$PIECE(RDAT,U,4)
+22 SET RMISN=$PIECE(RDAT,U,5)
+23 SET RMAVEN=$PIECE(RDAT,U,6)
+24 SET RMDLEN=$PIECE(RDAT,U,7)
+25 SET RMQOHU=$PIECE(RDAT,U,8)
+26 SET RMQOHN=$PIECE(RDAT,U,9)
+27 SET RMVALU=$PIECE(RDAT,U,10)
+28 SET RMVALN=$PIECE(RDAT,U,11)
+29 SET RMAVEU=$PIECE(RDAT,U,12)
+30 SET RMDLEU=$PIECE(RDAT,U,13)
+31 SET RMGISUG=RMGISUG+RMISU
+32 SET RMGISNG=RMGISNG+RMISN
+33 ;
+34 SET RMGTIU=RMGTIU+RMISU
+35 SET RMGTIN=RMGTIN+RMISN
+36 ;
+37 SET RMGTOU=RMGTOU+RMVALU
+38 SET RMGTON=RMGTON+RMVALN
+39 ;total for GROUP
+40 IF (RMCOM'="")
IF $GET(RMCOM)
SET RTUSEGC=RTUSEGC+RMCOM
+41 IF (RMVA'="")
IF $GET(RMVA)
SET RTUSEGA=RTUSEGA+RMVA
+42 SET RMTVAG=RMTVAG+RMVA
+43 SET RMTCOMG=RMTCOMG+RMCOM
+44 SET RMTISUG=RMTISUG+RMISU
+45 SET RMTISNG=RMTISNG+RMISN
+46 SET RMTQOHUG=RMTQOHUG+RMQOHU
+47 SET RMTQOHNG=RMTQOHNG+RMQOHN
+48 SET RMTVALUG=RMTVALUG+RMVALU
+49 SET RMTVALNG=RMTVALNG+RMVALN
+50 SET (RPRINT,RPR)=1
+51 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 HDRG
DO LBL1^RMPR5HQ2
+52 IF $Y+8>IOSL
IF IOST'["C-"
WRITE @IOF
DO HDRG
DO LBL1^RMPR5HQ2
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+53 IF '$GET(RPRINT)
WRITE !!,"No Records to Print !!"
QUIT
+54 if $GET(RFL)
QUIT
+55 WRITE !!,REQ
+56 SET RMGTOT=RMGTOU+RMGTON
+57 WRITE !!,?10,"GRAND TOTAL $ VALUE ISSUED (Used) = ",?38,"$",$JUSTIFY($FNUMBER(RMGISUG,",",2),10)
+58 WRITE ?80,"GRAND TOTAL $ VALUE ON-HAND (Used) = ",?115,"$",$JUSTIFY($FNUMBER(RMGTOU,",",2),12)
+59 WRITE !,?10,"GRAND TOTAL $ VALUE ISSUED (New) = ",?38,"$",$JUSTIFY($FNUMBER(RMGISNG,",",2),10)
+60 WRITE ?80,"GRAND TOTAL $ VALUE ON-HAND (New) = ",?115,"$",$JUSTIFY($FNUMBER(RMGTON,",",2),12)
+61 ;W !,?80,"GRAND TOTAL $ VALUE ON-HAND = ",?68,"$"_$J($FN(RMGTOT,",",2),12)
+62 WRITE !,"<End of Report>"
+63 QUIT
+64 ;
HDRG ;print heading.
+1 if $GET(RFL)
QUIT
+2 SET RMPAGE=RMPAGE+1
+3 WRITE !,"PROSTHETIC INVENTORY NPPD GROUP 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 WRITE !!,"ENTIRE SUMMARY"
+2 DO LBL1^RMPR5HQ2
+3 QUIT
+4 ;
SUMG1 ;print summary total for NPPD GROUP
+1 if $GET(RFL)
QUIT
+2 WRITE !,RLN
+3 WRITE !,RGRP," ",RNPGRP
+4 if $GET(RTUSEGA)
SET RTAVEGA=RTUSEGA/RMCALDAY
+5 if $GET(RTUSEGC)
SET RTAVEGC=RTUSEGC/RMCALDAY
+6 if $GET(RTUSEGA)
SET RTDLEGA=RMTQOHUG/RTAVEGA
+7 if $GET(RTUSEGC)
SET RTDLEGC=RMTQOHNG/RTAVEGC
+8 SET RTDLEGA=$SELECT(RTDLEGA>999:">999",1:$JUSTIFY(RTDLEGA,5,0))
+9 SET RTDLEGC=$SELECT(RTDLEGC>999:">999",1:$JUSTIFY(RTDLEGC,5,0))
+10 if RMTQOHNG=0
SET RTDLEGC=""
+11 if RMTQOHUG=0
SET RTDLEGA=""
+12 if (RMTQOHNG>0)&(RMTCOMG<1)
SET RTDLEGC=">"_RMCALDAY
+13 if (RMTQOHUG>0)&(RMTVAG<1)
SET RTDLEGA=">"_RMCALDAY
+14 ;next 2 lines for used:
+15 WRITE !,?5,"(Used)",?26,$JUSTIFY(RMTVAG,5),?34,$JUSTIFY($FNUMBER(RMTISUG,",",2),6),?40,"|",?59,"|",?60,$JUSTIFY(RTUSEGA,5),?67,"|",?71,$JUSTIFY(RTAVEGA,5,2),?78,"|"
+16 WRITE ?81,$JUSTIFY(RMTQOHUG,5),?94,"|",?97,$JUSTIFY(RTDLEGA,6),?103,"|",?104,$JUSTIFY($FNUMBER(RMTVALUG,",",2),11)
+17 ;next 2 lines for new:
+18 WRITE !,?5,"(New)",?40,"|",?41,$JUSTIFY(RMTCOMG,4),?49,$JUSTIFY($FNUMBER(RMTISNG,",",2),9),?59,"|",?60,$JUSTIFY(RTUSEGC,5),?67,"|",?71,$JUSTIFY(RTAVEGC,5,2),?78,"|"
+19 WRITE ?87,$JUSTIFY(RMTQOHNG,6),?94,"|",?97,$JUSTIFY(RTDLEGC,6),?103,"|",?116,$JUSTIFY($FNUMBER(RMTVALNG,",",2),11)
+20 SET (RMTVAG,RMTISUG,RMTCOMG,RMTISNG,RTUSEGA,RTUSEGC,RTAVEGA,RTAVEGC,RMTQOHUG,RMTQOHNG,RTDLEGA,RTDLEGC,RMTVALUG,RMTVALNG)=0
+21 SET (RNPGRP,RGRP)=""
+22 QUIT
