PRSDSRP ;HISC/GWB-STRENGTH REPORT PRINT ;8/23/93 14:28
;;4.0;PAID;**6**;Sep 21, 1995
ASKDEV S %ZIS="QM",%ZIS("B")="" D ^%ZIS G EXIT:POP
I IOM<132 D ^%ZISC W !,*7,"Please select a right margin of at least 132.",! G ASKDEV
I $D(IO("Q")) D Q
.S ZTRTN="START^PRSDSRP",ZTDESC="PAID STRENGTH REPORT"
.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued!" D HOME^%ZIS K IO("Q") Q
START U IO D NOW^%DTC S Y=$J(%,"",4) D DD^%DT S PRNTDT=Y
S $P(DASHES,"-",87)="-"
S DASHES=DASHES_"|-------------------------|------------------"
S PAGE=0,FIRST="1ST",PRTC=1,COMPDT=""
S SN=$P($G(^XMB(1,1,"XUS")),"^",17)
S SITE=$S(+SN>0:$P($G(^DIC(4,SN,0)),U,1),1:"")
S:SITE'="" SITE=" FOR "_SITE
S (CLGTL,FTPTL,PTPTL,PTPFTETL,FTTTL,PTTTL,PTTFTETL,INTTL,INTFTETL)=0
S (TSRTL,TSRFTETL,SISTL,TOTTL,FTETOTTL,VARTL,LWOPTL,FEETL)=0
MCAY D INISB S CCORG="" F S CCORG=$O(^PRSP(454.1,"B",CCORG)) Q:CCORG="" S CCORGIEN=0,CCORGIEN=$O(^PRSP(454.1,"B",CCORG,CCORGIEN)) I $P(^PRSP(454.1,CCORGIEN,0),U,2)="Y",$D(^PRSP(454.1,CCORGIEN,1)),^PRSP(454.1,CCORGIEN,1)'="" D WRITE Q:PRTC=0
G:PRTC=0 EXIT
D WRITESB G:PRTC=0 EXIT
MCAN D INISB S CCORG="" F S CCORG=$O(^PRSP(454.1,"B",CCORG)) Q:CCORG="" S CCORGIEN=0,CCORGIEN=$O(^PRSP(454.1,"B",CCORG,CCORGIEN)) I $P(^PRSP(454.1,CCORGIEN,0),U,2)="N",$D(^PRSP(454.1,CCORGIEN,1)),^PRSP(454.1,CCORGIEN,1)'="" D WRITE Q:PRTC=0
G:PRTC=0 EXIT
D:TOTSB>0 WRITESB G:PRTC=0 EXIT
W !,DASHES I $Y>(IOSL-4) D:$E(IOST,1)="C" PRTC G:PRTC=0 EXIT D HDR
W !,?17,"TOTAL",?24,$J(CLGTL,7,2),?33,$J(FTPTL,4),?38,$J(PTPTL,4)
W ?43,$J(PTPFTETL,7,2),?51,$J(FTTTL,4),?56,$J(PTTTL,4)
W ?61,$J(PTTFTETL,7,2),?69,$J(INTTL,4),?74,$J(SISTL,4)
W ?79,$J(INTFTETL,7,2),?87,"|",?90,$J(TOTTL,4),?97,$J(FTETOTTL,7,2)
W ?105,$J(VARTL,7,2),?113,"|",?113,$J(TSRTL,3),?117,$J(TSRFTETL,7,2)
W ?125,$J(LWOPTL,3),?129,$J(FEETL,3)
W !,DASHES I $E(IOST,1)="C" D PRTC G:PRTC=0 EXIT
D LEGEND^PRSDSRP2 D:$E(IOST,1)="C" PRTC G:PRTC=0 EXIT
D ^PRSDSRP2
D ^%ZISC
EXIT S:$D(ZTQUEUED) ZTREQ="@" D KILL^XUSCLEAN Q
INISB S (CLGSB,FTPSB,PTPSB,PTPFTESB,FTTSB,PTTSB,PTTFTESB,INTSB,INTFTESB)=0
S (TSRSB,TSRFTESB,SISSB,TOTSB,FTETOTSB,VARSB,LWOPSB,FEESB)=0 Q
WRITE I FIRST="1ST" S Y=$P(^PRSP(454.1,CCORGIEN,0),U,3) D DD^%DT S COMPDT=Y D HDR S FIRST=""
S ZERO=^PRSP(454.1,CCORGIEN,0),ONE=^PRSP(454.1,CCORGIEN,1)
S CLG=$P(ZERO,U,4)
S FTP=$P(ONE,U,1),FTT=$P(ONE,U,2),PTP=$P(ONE,U,3),PTPFTE=$P(ONE,U,4)
S PTT=$P(ONE,U,5),PTTFTE=$P(ONE,U,6),INT=$P(ONE,U,7),INTFTE=$P(ONE,U,8)
S TSR=$P(ONE,U,9),TSRFTE=$P(ONE,U,10),SIS=$P(ONE,U,11),TOT=$P(ONE,U,12)
S FTETOT=$P(ONE,U,13),VAR=$P(ONE,U,14),LWOP=$P(ONE,U,15)
S FEE=$P(ONE,U,16)
S CLGSB=CLGSB+CLG,FTPSB=FTPSB+FTP,PTPSB=PTPSB+PTP
S PTPFTESB=PTPFTESB+PTPFTE,FTTSB=FTTSB+FTT,PTTSB=PTTSB+PTT
S PTTFTESB=PTTFTESB+PTTFTE,INTSB=INTSB+INT,INTFTESB=INTFTESB+INTFTE
S TSRSB=TSRSB+TSR,TSRFTESB=TSRFTESB+TSRFTE,SISSB=SISSB+SIS
S TOTSB=TOTSB+TOT,FTETOTSB=FTETOTSB+FTETOT,VARSB=VARSB+VAR
S LWOPSB=LWOPSB+LWOP,FEESB=FEESB+FEE
W !,$P(^PRSP(454.1,CCORGIEN,0),U,1)
I $P(^PRSP(454.1,CCORGIEN,0),U,1)="NURSING" D ^PRSDSRP1 Q:PRTC=0
W ?24,$J(CLG,7,2),?33,$J(FTP,4),?38,$J(PTP,4),?43,$J(PTPFTE,7,2)
W ?51,$J(FTT,4),?56,$J(PTT,4),?61,$J(PTTFTE,7,2),?69,$J(INT,4)
W ?74,$J(SIS,4),?79,$J(INTFTE,7,2),?87,"|",?90,$J(TOT,4)
W ?97,$J(FTETOT,7,2),?105,$J(VAR,7,2),?113,"|",?113,$J(TSR,3)
W ?117,$J(TSRFTE,7,2),?125,$J(LWOP,3),?129,$J(FEE,3)
W !,DASHES I $Y>(IOSL-4) D:$E(IOST,1)="C" PRTC Q:PRTC=0 D HDR
Q
WRITESB W !,?14,"SUBTOTAL",?24,$J(CLGSB,7,2),?33,$J(FTPSB,4),?38,$J(PTPSB,4)
W ?43,$J(PTPFTESB,7,2),?51,$J(FTTSB,4),?56,$J(PTTSB,4)
W ?61,$J(PTTFTESB,7,2),?69,$J(INTSB,4),?74,$J(SISSB,4)
W ?79,$J(INTFTESB,7,2),?87,"|",?90,$J(TOTSB,4),?97,$J(FTETOTSB,7,2)
W ?105,$J(VARSB,7,2),?113,"|",?113,$J(TSRSB,3),?117,$J(TSRFTESB,7,2)
W ?125,$J(LWOPSB,3),?129,$J(FEESB,3)
I $Y>(IOSL-2) D:$E(IOST,1)="C" PRTC Q:PRTC=0 D HDR
W !,DASHES I $Y>(IOSL-2) D:$E(IOST,1)="C" PRTC Q:PRTC=0 D HDR
S CLGTL=CLGTL+CLGSB,FTPTL=FTPTL+FTPSB,PTPTL=PTPTL+PTPSB
S PTPFTETL=PTPFTETL+PTPFTESB,FTTTL=FTTTL+FTTSB,PTTTL=PTTTL+PTTSB
S PTTFTETL=PTTFTETL+PTTFTESB,INTTL=INTTL+INTSB
S INTFTETL=INTFTETL+INTFTESB,TSRTL=TSRTL+TSRSB
S TSRFTETL=TSRFTETL+TSRFTESB,SISTL=SISTL+SISSB,TOTTL=TOTTL+TOTSB
S FTETOTTL=FTETOTTL+FTETOTSB,VARTL=VARTL+VARSB,LWOPTL=LWOPTL+LWOPSB
S FEETL=FEETL+FEESB Q
HDR W:$Y>0 @IOF S PAGE=PAGE+1
W !,"STRENGTH REPORT",SITE,?96,"COMPILATION DATE: ",COMPDT
W !,"PAGE: ",PAGE,?102,"PRINT DATE: ",PRNTDT,!
W !,?80,"SISFTE"
W !,"SERVICE NAME",?24,"CEILING",?34,"FTP",?39,"PTP",?44,"PTPFTE"
W ?52,"FTT",?57,"PTT",?62,"PTTFTE",?70,"INT",?75,"SIS",?80,"INTFTE"
W ?87,"|",?91,"TOT",?98,"FTETOT",?109,"VAR",?113,"|TSR",?118,"TSRFTE"
W ?125,"LWP",?129,"FEE"
W !,DASHES,!,DASHES
Q
PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y S:$D(DIRUT) PRTC=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDSRP 4879 printed Dec 13, 2024@02:26:05 Page 2
PRSDSRP ;HISC/GWB-STRENGTH REPORT PRINT ;8/23/93 14:28
+1 ;;4.0;PAID;**6**;Sep 21, 1995
ASKDEV SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO EXIT
+1 IF IOM<132
DO ^%ZISC
WRITE !,*7,"Please select a right margin of at least 132.",!
GOTO ASKDEV
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="START^PRSDSRP"
SET ZTDESC="PAID STRENGTH REPORT"
+4 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Request Queued!"
DO HOME^%ZIS
KILL IO("Q")
QUIT
End DoDot:1
QUIT
START USE IO
DO NOW^%DTC
SET Y=$JUSTIFY(%,"",4)
DO DD^%DT
SET PRNTDT=Y
+1 SET $PIECE(DASHES,"-",87)="-"
+2 SET DASHES=DASHES_"|-------------------------|------------------"
+3 SET PAGE=0
SET FIRST="1ST"
SET PRTC=1
SET COMPDT=""
+4 SET SN=$PIECE($GET(^XMB(1,1,"XUS")),"^",17)
+5 SET SITE=$SELECT(+SN>0:$PIECE($GET(^DIC(4,SN,0)),U,1),1:"")
+6 if SITE'=""
SET SITE=" FOR "_SITE
+7 SET (CLGTL,FTPTL,PTPTL,PTPFTETL,FTTTL,PTTTL,PTTFTETL,INTTL,INTFTETL)=0
+8 SET (TSRTL,TSRFTETL,SISTL,TOTTL,FTETOTTL,VARTL,LWOPTL,FEETL)=0
MCAY DO INISB
SET CCORG=""
FOR
SET CCORG=$ORDER(^PRSP(454.1,"B",CCORG))
if CCORG=""
QUIT
SET CCORGIEN=0
SET CCORGIEN=$ORDER(^PRSP(454.1,"B",CCORG,CCORGIEN))
IF $PIECE(^PRSP(454.1,CCORGIEN,0),U,2)="Y"
IF $DATA(^PRSP(454.1,CCORGIEN,1))
IF ^PRSP(454.1,CCORGIEN,1)'=""
DO WRITE
if PRTC=0
QUIT
+1 if PRTC=0
GOTO EXIT
+2 DO WRITESB
if PRTC=0
GOTO EXIT
MCAN DO INISB
SET CCORG=""
FOR
SET CCORG=$ORDER(^PRSP(454.1,"B",CCORG))
if CCORG=""
QUIT
SET CCORGIEN=0
SET CCORGIEN=$ORDER(^PRSP(454.1,"B",CCORG,CCORGIEN))
IF $PIECE(^PRSP(454.1,CCORGIEN,0),U,2)="N"
IF $DATA(^PRSP(454.1,CCORGIEN,1))
IF ^PRSP(454.1,CCORGIEN,1)'=""
DO WRITE
if PRTC=0
QUIT
+1 if PRTC=0
GOTO EXIT
+2 if TOTSB>0
DO WRITESB
if PRTC=0
GOTO EXIT
+3 WRITE !,DASHES
IF $Y>(IOSL-4)
if $EXTRACT(IOST,1)="C"
DO PRTC
if PRTC=0
GOTO EXIT
DO HDR
+4 WRITE !,?17,"TOTAL",?24,$JUSTIFY(CLGTL,7,2),?33,$JUSTIFY(FTPTL,4),?38,$JUSTIFY(PTPTL,4)
+5 WRITE ?43,$JUSTIFY(PTPFTETL,7,2),?51,$JUSTIFY(FTTTL,4),?56,$JUSTIFY(PTTTL,4)
+6 WRITE ?61,$JUSTIFY(PTTFTETL,7,2),?69,$JUSTIFY(INTTL,4),?74,$JUSTIFY(SISTL,4)
+7 WRITE ?79,$JUSTIFY(INTFTETL,7,2),?87,"|",?90,$JUSTIFY(TOTTL,4),?97,$JUSTIFY(FTETOTTL,7,2)
+8 WRITE ?105,$JUSTIFY(VARTL,7,2),?113,"|",?113,$JUSTIFY(TSRTL,3),?117,$JUSTIFY(TSRFTETL,7,2)
+9 WRITE ?125,$JUSTIFY(LWOPTL,3),?129,$JUSTIFY(FEETL,3)
+10 WRITE !,DASHES
IF $EXTRACT(IOST,1)="C"
DO PRTC
if PRTC=0
GOTO EXIT
+11 DO LEGEND^PRSDSRP2
if $EXTRACT(IOST,1)="C"
DO PRTC
if PRTC=0
GOTO EXIT
+12 DO ^PRSDSRP2
+13 DO ^%ZISC
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
DO KILL^XUSCLEAN
QUIT
INISB SET (CLGSB,FTPSB,PTPSB,PTPFTESB,FTTSB,PTTSB,PTTFTESB,INTSB,INTFTESB)=0
+1 SET (TSRSB,TSRFTESB,SISSB,TOTSB,FTETOTSB,VARSB,LWOPSB,FEESB)=0
QUIT
WRITE IF FIRST="1ST"
SET Y=$PIECE(^PRSP(454.1,CCORGIEN,0),U,3)
DO DD^%DT
SET COMPDT=Y
DO HDR
SET FIRST=""
+1 SET ZERO=^PRSP(454.1,CCORGIEN,0)
SET ONE=^PRSP(454.1,CCORGIEN,1)
+2 SET CLG=$PIECE(ZERO,U,4)
+3 SET FTP=$PIECE(ONE,U,1)
SET FTT=$PIECE(ONE,U,2)
SET PTP=$PIECE(ONE,U,3)
SET PTPFTE=$PIECE(ONE,U,4)
+4 SET PTT=$PIECE(ONE,U,5)
SET PTTFTE=$PIECE(ONE,U,6)
SET INT=$PIECE(ONE,U,7)
SET INTFTE=$PIECE(ONE,U,8)
+5 SET TSR=$PIECE(ONE,U,9)
SET TSRFTE=$PIECE(ONE,U,10)
SET SIS=$PIECE(ONE,U,11)
SET TOT=$PIECE(ONE,U,12)
+6 SET FTETOT=$PIECE(ONE,U,13)
SET VAR=$PIECE(ONE,U,14)
SET LWOP=$PIECE(ONE,U,15)
+7 SET FEE=$PIECE(ONE,U,16)
+8 SET CLGSB=CLGSB+CLG
SET FTPSB=FTPSB+FTP
SET PTPSB=PTPSB+PTP
+9 SET PTPFTESB=PTPFTESB+PTPFTE
SET FTTSB=FTTSB+FTT
SET PTTSB=PTTSB+PTT
+10 SET PTTFTESB=PTTFTESB+PTTFTE
SET INTSB=INTSB+INT
SET INTFTESB=INTFTESB+INTFTE
+11 SET TSRSB=TSRSB+TSR
SET TSRFTESB=TSRFTESB+TSRFTE
SET SISSB=SISSB+SIS
+12 SET TOTSB=TOTSB+TOT
SET FTETOTSB=FTETOTSB+FTETOT
SET VARSB=VARSB+VAR
+13 SET LWOPSB=LWOPSB+LWOP
SET FEESB=FEESB+FEE
+14 WRITE !,$PIECE(^PRSP(454.1,CCORGIEN,0),U,1)
+15 IF $PIECE(^PRSP(454.1,CCORGIEN,0),U,1)="NURSING"
DO ^PRSDSRP1
if PRTC=0
QUIT
+16 WRITE ?24,$JUSTIFY(CLG,7,2),?33,$JUSTIFY(FTP,4),?38,$JUSTIFY(PTP,4),?43,$JUSTIFY(PTPFTE,7,2)
+17 WRITE ?51,$JUSTIFY(FTT,4),?56,$JUSTIFY(PTT,4),?61,$JUSTIFY(PTTFTE,7,2),?69,$JUSTIFY(INT,4)
+18 WRITE ?74,$JUSTIFY(SIS,4),?79,$JUSTIFY(INTFTE,7,2),?87,"|",?90,$JUSTIFY(TOT,4)
+19 WRITE ?97,$JUSTIFY(FTETOT,7,2),?105,$JUSTIFY(VAR,7,2),?113,"|",?113,$JUSTIFY(TSR,3)
+20 WRITE ?117,$JUSTIFY(TSRFTE,7,2),?125,$JUSTIFY(LWOP,3),?129,$JUSTIFY(FEE,3)
+21 WRITE !,DASHES
IF $Y>(IOSL-4)
if $EXTRACT(IOST,1)="C"
DO PRTC
if PRTC=0
QUIT
DO HDR
+22 QUIT
WRITESB WRITE !,?14,"SUBTOTAL",?24,$JUSTIFY(CLGSB,7,2),?33,$JUSTIFY(FTPSB,4),?38,$JUSTIFY(PTPSB,4)
+1 WRITE ?43,$JUSTIFY(PTPFTESB,7,2),?51,$JUSTIFY(FTTSB,4),?56,$JUSTIFY(PTTSB,4)
+2 WRITE ?61,$JUSTIFY(PTTFTESB,7,2),?69,$JUSTIFY(INTSB,4),?74,$JUSTIFY(SISSB,4)
+3 WRITE ?79,$JUSTIFY(INTFTESB,7,2),?87,"|",?90,$JUSTIFY(TOTSB,4),?97,$JUSTIFY(FTETOTSB,7,2)
+4 WRITE ?105,$JUSTIFY(VARSB,7,2),?113,"|",?113,$JUSTIFY(TSRSB,3),?117,$JUSTIFY(TSRFTESB,7,2)
+5 WRITE ?125,$JUSTIFY(LWOPSB,3),?129,$JUSTIFY(FEESB,3)
+6 IF $Y>(IOSL-2)
if $EXTRACT(IOST,1)="C"
DO PRTC
if PRTC=0
QUIT
DO HDR
+7 WRITE !,DASHES
IF $Y>(IOSL-2)
if $EXTRACT(IOST,1)="C"
DO PRTC
if PRTC=0
QUIT
DO HDR
+8 SET CLGTL=CLGTL+CLGSB
SET FTPTL=FTPTL+FTPSB
SET PTPTL=PTPTL+PTPSB
+9 SET PTPFTETL=PTPFTETL+PTPFTESB
SET FTTTL=FTTTL+FTTSB
SET PTTTL=PTTTL+PTTSB
+10 SET PTTFTETL=PTTFTETL+PTTFTESB
SET INTTL=INTTL+INTSB
+11 SET INTFTETL=INTFTETL+INTFTESB
SET TSRTL=TSRTL+TSRSB
+12 SET TSRFTETL=TSRFTETL+TSRFTESB
SET SISTL=SISTL+SISSB
SET TOTTL=TOTTL+TOTSB
+13 SET FTETOTTL=FTETOTTL+FTETOTSB
SET VARTL=VARTL+VARSB
SET LWOPTL=LWOPTL+LWOPSB
+14 SET FEETL=FEETL+FEESB
QUIT
HDR if $Y>0
WRITE @IOF
SET PAGE=PAGE+1
+1 WRITE !,"STRENGTH REPORT",SITE,?96,"COMPILATION DATE: ",COMPDT
+2 WRITE !,"PAGE: ",PAGE,?102,"PRINT DATE: ",PRNTDT,!
+3 WRITE !,?80,"SISFTE"
+4 WRITE !,"SERVICE NAME",?24,"CEILING",?34,"FTP",?39,"PTP",?44,"PTPFTE"
+5 WRITE ?52,"FTT",?57,"PTT",?62,"PTTFTE",?70,"INT",?75,"SIS",?80,"INTFTE"
+6 WRITE ?87,"|",?91,"TOT",?98,"FTETOT",?109,"VAR",?113,"|TSR",?118,"TSRFTE"
+7 WRITE ?125,"LWP",?129,"FEE"
+8 WRITE !,DASHES,!,DASHES
+9 QUIT
PRTC WRITE !
KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
SET PRTC=Y
if $DATA(DIRUT)
SET PRTC=0
+1 QUIT
