- PRSDSRP2 ;HISC/GWB-STRENGTH REPORT PRINT (CONTINUED);7/22/93 13:48
- ;;4.0;PAID;**6**;Sep 21, 1995
- D HDR
- S (CLGTL,FTPTL,PTPTL,PTPFTETL,FTTTL,PTTTL,PTTFTETL,INTTL,INTFTETL)=0
- S (TSRTL,TSRFTETL,SISTL,TOTTL,FTETOTTL,VARTL,LWOPTL,FEETL)=0
- MCAY 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 $D(^PRSP(454.1,CCORGIEN,2)),^PRSP(454.1,CCORGIEN,2)'="",$P(^PRSP(454.1,CCORGIEN,0),U,2)="Y" D WRITE
- W !,DASHES
- I $Y>(IOSL-4) D:$E(IOST,1)="C" PRTC^PRSDSRP 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 D:$E(IOST,1)="C" PRTC^PRSDSRP G:PRTC=0 EXIT
- D LEGEND D:$E(IOST,1)="C" PRTC^PRSDSRP G:PRTC=0 EXIT W !
- EXIT D KILL^XUSCLEAN 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),TWO=^PRSP(454.1,CCORGIEN,2)
- S CLG=$P(ZERO,U,5)
- S FTP=$P(TWO,U,1),FTT=$P(TWO,U,2),PTP=$P(TWO,U,3),PTPFTE=$P(TWO,U,4)
- S PTT=$P(TWO,U,5),PTTFTE=$P(TWO,U,6),INT=$P(TWO,U,7),INTFTE=$P(TWO,U,8)
- S TSR=$P(TWO,U,9),TSRFTE=$P(TWO,U,10),SIS=$P(TWO,U,11),TOT=$P(TWO,U,12)
- S FTETOT=$P(TWO,U,13),VAR=$P(TWO,U,14),LWOP=$P(TWO,U,15)
- S FEE=$P(TWO,U,16)
- S CLGTL=CLGTL+CLG,FTPTL=FTPTL+FTP,PTPTL=PTPTL+PTP
- S PTPFTETL=PTPFTETL+PTPFTE,FTTTL=FTTTL+FTT,PTTTL=PTTTL+PTT
- S PTTFTETL=PTTFTETL+PTTFTE,INTTL=INTTL+INT,INTFTETL=INTFTETL+INTFTE
- S TSRTL=TSRTL+TSR,TSRFTETL=TSRFTETL+TSRFTE,SISTL=SISTL+SIS
- S TOTTL=TOTTL+TOT,FTETOTTL=FTETOTTL+FTETOT,VARTL=VARTL+VAR
- S LWOPTL=LWOPTL+LWOP,FEETL=FEETL+FEE
- W !,$P(^PRSP(454.1,CCORGIEN,0),U,1),?24,$J(CLG,7,2),?33,$J(FTP,4)
- W ?38,$J(PTP,4),?43,$J(PTPFTE,7,2),?51,$J(FTT,4),?56,$J(PTT,4)
- W ?61,$J(PTTFTE,7,2),?69,$J(INT,4),?74,$J(SIS,4),?79,$J(INTFTE,7,2)
- W ?87,"|",?90,$J(TOT,4),?97,$J(FTETOT,7,2),?105,$J(VAR,7,2),?113,"|"
- W ?113,$J(TSR,3),?117,$J(TSRFTE,7,2),?125,$J(LWOP,3),?129,$J(FEE,3)
- W !,DASHES D:$Y>(IOSL-2) HDR Q
- HDR W:$Y>0 @IOF S PAGE=PAGE+1
- W "PHYSICIAN 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,"|",?113,"TSR"
- W ?118,"TSRFTE",?125,"LWP",?129,"FEE"
- W !,DASHES,!,DASHES
- Q
- LEGEND W !,"FTP Full Time Permanent",?40,"SIS Stay-in-School/Summer Aid"
- W !,"PTP Part Time Permanent",?40,"VAR Variance (FTETOT-CEILING)"
- W !,"FTT Full Time Temporary",?40,"TSR Trainee/Stipend/Resident"
- W !,"PTT Part Time Temporary",?40,"LWP Extended Leave Without Pay"
- W !,"INT Intermittent",?40,"FEE Fee Basis"
- I $D(^XTMP("CCORG")) D
- .W !!," The following Cost Center/Organization codes are not associated with a service name and are being counted under the service name"
- .W !,"MISCELLANEOUS. You may assign them a service name via the Update PAID Codes option by choosing the COST CENTER/ORGANIZATION file, "
- .W !,"entering the CODE and entering a DESCRIPTION. You must then recompile the report via the Compile/Print Strength Report option."
- .W !,"These code will then be counted under the appropriate service name.",!
- .S CCORG="" F S CCORG=$O(^XTMP("CCORG",CCORG)) Q:CCORG="" W !,CCORG
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDSRP2 3638 printed Feb 18, 2025@23:52:38 Page 2
- PRSDSRP2 ;HISC/GWB-STRENGTH REPORT PRINT (CONTINUED);7/22/93 13:48
- +1 ;;4.0;PAID;**6**;Sep 21, 1995
- +2 DO HDR
- +3 SET (CLGTL,FTPTL,PTPTL,PTPFTETL,FTTTL,PTTTL,PTTFTETL,INTTL,INTFTETL)=0
- +4 SET (TSRTL,TSRFTETL,SISTL,TOTTL,FTETOTTL,VARTL,LWOPTL,FEETL)=0
- MCAY 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 $DATA(^PRSP(454.1,CCORGIEN,2))
- IF ^PRSP(454.1,CCORGIEN,2)'=""
- IF $PIECE(^PRSP(454.1,CCORGIEN,0),U,2)="Y"
- DO WRITE
- +1 WRITE !,DASHES
- +2 IF $Y>(IOSL-4)
- if $EXTRACT(IOST,1)="C"
- DO PRTC^PRSDSRP
- if PRTC=0
- GOTO EXIT
- DO HDR
- +3 WRITE !,?17,"TOTAL",?24,$JUSTIFY(CLGTL,7,2),?33,$JUSTIFY(FTPTL,4),?38,$JUSTIFY(PTPTL,4)
- +4 WRITE ?43,$JUSTIFY(PTPFTETL,7,2),?51,$JUSTIFY(FTTTL,4),?56,$JUSTIFY(PTTTL,4)
- +5 WRITE ?61,$JUSTIFY(PTTFTETL,7,2),?69,$JUSTIFY(INTTL,4),?74,$JUSTIFY(SISTL,4)
- +6 WRITE ?79,$JUSTIFY(INTFTETL,7,2),?87,"|",?90,$JUSTIFY(TOTTL,4),?97,$JUSTIFY(FTETOTTL,7,2)
- +7 WRITE ?105,$JUSTIFY(VARTL,7,2),?113,"|",?113,$JUSTIFY(TSRTL,3),?117,$JUSTIFY(TSRFTETL,7,2)
- +8 WRITE ?125,$JUSTIFY(LWOPTL,3),?129,$JUSTIFY(FEETL,3)
- +9 WRITE !,DASHES
- if $EXTRACT(IOST,1)="C"
- DO PRTC^PRSDSRP
- if PRTC=0
- GOTO EXIT
- +10 DO LEGEND
- if $EXTRACT(IOST,1)="C"
- DO PRTC^PRSDSRP
- if PRTC=0
- GOTO EXIT
- WRITE !
- EXIT DO KILL^XUSCLEAN
- 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 TWO=^PRSP(454.1,CCORGIEN,2)
- +2 SET CLG=$PIECE(ZERO,U,5)
- +3 SET FTP=$PIECE(TWO,U,1)
- SET FTT=$PIECE(TWO,U,2)
- SET PTP=$PIECE(TWO,U,3)
- SET PTPFTE=$PIECE(TWO,U,4)
- +4 SET PTT=$PIECE(TWO,U,5)
- SET PTTFTE=$PIECE(TWO,U,6)
- SET INT=$PIECE(TWO,U,7)
- SET INTFTE=$PIECE(TWO,U,8)
- +5 SET TSR=$PIECE(TWO,U,9)
- SET TSRFTE=$PIECE(TWO,U,10)
- SET SIS=$PIECE(TWO,U,11)
- SET TOT=$PIECE(TWO,U,12)
- +6 SET FTETOT=$PIECE(TWO,U,13)
- SET VAR=$PIECE(TWO,U,14)
- SET LWOP=$PIECE(TWO,U,15)
- +7 SET FEE=$PIECE(TWO,U,16)
- +8 SET CLGTL=CLGTL+CLG
- SET FTPTL=FTPTL+FTP
- SET PTPTL=PTPTL+PTP
- +9 SET PTPFTETL=PTPFTETL+PTPFTE
- SET FTTTL=FTTTL+FTT
- SET PTTTL=PTTTL+PTT
- +10 SET PTTFTETL=PTTFTETL+PTTFTE
- SET INTTL=INTTL+INT
- SET INTFTETL=INTFTETL+INTFTE
- +11 SET TSRTL=TSRTL+TSR
- SET TSRFTETL=TSRFTETL+TSRFTE
- SET SISTL=SISTL+SIS
- +12 SET TOTTL=TOTTL+TOT
- SET FTETOTTL=FTETOTTL+FTETOT
- SET VARTL=VARTL+VAR
- +13 SET LWOPTL=LWOPTL+LWOP
- SET FEETL=FEETL+FEE
- +14 WRITE !,$PIECE(^PRSP(454.1,CCORGIEN,0),U,1),?24,$JUSTIFY(CLG,7,2),?33,$JUSTIFY(FTP,4)
- +15 WRITE ?38,$JUSTIFY(PTP,4),?43,$JUSTIFY(PTPFTE,7,2),?51,$JUSTIFY(FTT,4),?56,$JUSTIFY(PTT,4)
- +16 WRITE ?61,$JUSTIFY(PTTFTE,7,2),?69,$JUSTIFY(INT,4),?74,$JUSTIFY(SIS,4),?79,$JUSTIFY(INTFTE,7,2)
- +17 WRITE ?87,"|",?90,$JUSTIFY(TOT,4),?97,$JUSTIFY(FTETOT,7,2),?105,$JUSTIFY(VAR,7,2),?113,"|"
- +18 WRITE ?113,$JUSTIFY(TSR,3),?117,$JUSTIFY(TSRFTE,7,2),?125,$JUSTIFY(LWOP,3),?129,$JUSTIFY(FEE,3)
- +19 WRITE !,DASHES
- if $Y>(IOSL-2)
- DO HDR
- QUIT
- HDR if $Y>0
- WRITE @IOF
- SET PAGE=PAGE+1
- +1 WRITE "PHYSICIAN 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,"|",?113,"TSR"
- +7 WRITE ?118,"TSRFTE",?125,"LWP",?129,"FEE"
- +8 WRITE !,DASHES,!,DASHES
- +9 QUIT
- LEGEND WRITE !,"FTP Full Time Permanent",?40,"SIS Stay-in-School/Summer Aid"
- +1 WRITE !,"PTP Part Time Permanent",?40,"VAR Variance (FTETOT-CEILING)"
- +2 WRITE !,"FTT Full Time Temporary",?40,"TSR Trainee/Stipend/Resident"
- +3 WRITE !,"PTT Part Time Temporary",?40,"LWP Extended Leave Without Pay"
- +4 WRITE !,"INT Intermittent",?40,"FEE Fee Basis"
- +5 IF $DATA(^XTMP("CCORG"))
- Begin DoDot:1
- +6 WRITE !!," The following Cost Center/Organization codes are not associated with a service name and are being counted under the service name"
- +7 WRITE !,"MISCELLANEOUS. You may assign them a service name via the Update PAID Codes option by choosing the COST CENTER/ORGANIZATION file, "
- +8 WRITE !,"entering the CODE and entering a DESCRIPTION. You must then recompile the report via the Compile/Print Strength Report option."
- +9 WRITE !,"These code will then be counted under the appropriate service name.",!
- +10 SET CCORG=""
- FOR
- SET CCORG=$ORDER(^XTMP("CCORG",CCORG))
- if CCORG=""
- QUIT
- WRITE !,CCORG
- End DoDot:1
- +11 QUIT