PRSDSRC ;HISC/GWB-STRENGTH REPORT COMPILATION ;8/23/93 15:34
;;4.0;PAID;**6,101**;Sep 21, 1995
TASK S %=0 W !!,"Do you wish to queue this job" D YN^DICN
I %=-1 G EXIT
I %=0 W !!,"Answer 'Y' if you wish this job to be run as a background job.",!,"Answer 'N' if you wish this job to be run interactively." G TASK
ASKDEV I %=1 S %ZIS="QMN",%ZIS("B")="",OUT="" D ^%ZIS G EXIT:POP D G:OUT="Y" ASKDEV G EXIT
.I IO=IO(0),$E(IOST,1)="C" W !,*7,"Please select a device other than your home device.",! S OUT="Y" Q
.I $D(IO("S")) W !,*7,"Please select a device other than a slave device.",! S OUT="Y" Q
.I IOM<132 W !,*7,"Please select a right margin of at least 132.",! S OUT="Y" Q
.S ZTRTN="START^PRSDSRC",ZTDESC="PAID STRENGTH REPORT"
.D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q
START D NOW^%DTC S COMPDT=$J(%,"",4)
S MISCIEN=0,MISCIEN=$O(^PRSP(454.1,"B","MISCELLANEOUS",MISCIEN))
D INIT
S CCORG="" F S CCORG=$O(^PRSPC("ACC",CCORG)) Q:CCORG'>0 W:'$D(ZTSK) "." D CCORG S IEN=0 F S IEN=$O(^PRSPC("ACC",CCORG,IEN)) D:IEN'>0 ^PRSDSRC1 Q:IEN'>0 D CATCNT D:'$D(NOSUB) SUBCAT K NOSUB
PRINT I $D(ZTQUEUED) D START^PRSDSRP G EXIT
D ^PRSDSRP
EXIT S:$D(ZTQUEUED) ZTREQ="@" K ^XTMP("CCORG") D KILL^XUSCLEAN Q
CATCNT S ZERO=^PRSPC(IEN,0)
S ONE=^PRSPC(IEN,1)
S ASN=$P(ZERO,U,4),DBS=$P(ZERO,U,10),OST=$P(ZERO,U,17)
S OCC=$E($P(ZERO,U,17),1,4),PBS=$P(ZERO,U,20),PPL=$P(ZERO,U,21)
S SAL=$P(ZERO,U,29),TOA=$P(ZERO,U,43)
S FTE=$P($G(^PRSPC(IEN,"MISC4")),U,11)
S GPY=$P($G(^PRSPC(IEN,"MEDICARE")),U,6)
S ITR=$P($G(^PRSPC(IEN,"T38")),U,15)
S LWOPIND=$P($G(^PRSPC(IEN,"LWOP")),U,1)
S SAL=$S("2EF457X"[PBS:SAL*2087,1:SAL)
S GPYTOT=GPYTOT+GPY,PRJSAL=PRJSAL+SAL
I PPL="F",$E($P(ONE,U,33),1)'="Y" S FEE=FEE+1 Q
I LWOPIND="Y" S LWOP=LWOP+1
I ($E(ASN,1)="T")!($E(ASN,1)="A")!(OST="060552")!(OST="060556")!(OST="061071")!(OST="061072")!(OST="061080")!(OST="061083")!(OST="063160")!(PBS="S")!(ITR>0) S TSR=TSR+1,TSRFTE=TSRFTE+FTE,NOSUB="" Q
S TOT=TOT+1,FTETOT=FTETOT+FTE
I "12579DRSWMNEAHUF"[TOA S:DBS=1 FTP=FTP+1 S:DBS=2 PTP=PTP+1,PTPFTE=PTPFTE+FTE S:DBS=3 INT=INT+1,INTFTE=INTFTE+FTE Q
I "3468JKLTVPZ"[TOA S:DBS=1 FTT=FTT+1 S:DBS=2 PTT=PTT+1,PTTFTE=PTTFTE+FTE S:DBS=3 INT=INT+1,INTFTE=INTFTE+FTE Q
I "XY"[TOA S SIS=SIS+1,INTFTE=INTFTE+FTE Q
I DBS=3 S INT=INT+1,INTFTE=INTFTE+FTE Q
Q
SUBCAT I (OCC="0602")!(OCC="0680")!(OCC="0662")!(OCC="0668") D MD^PRSDSRC2 Q
Q:CCORGNAM'="NURSING"
I OCC="0610" D RN^PRSDSRC2 Q
I OCC="0620" D LP^PRSDSRC2 Q
I OCC="0621" D NA^PRSDSRC2 Q
Q
INIT S CCORGIEN=0 F S CCORGIEN=$O(^PRSP(454.1,CCORGIEN)) Q:CCORGIEN'>0 D
.S $P(^PRSP(454.1,CCORGIEN,0),U,3)=""
.S ^PRSP(454.1,CCORGIEN,1)="",^PRSP(454.1,CCORGIEN,2)=""
.S ^PRSP(454.1,CCORGIEN,3)="",^PRSP(454.1,CCORGIEN,4)=""
.S ^PRSP(454.1,CCORGIEN,5)="",^PRSP(454.1,CCORGIEN,6)=""
K ^XTMP("CCORG")
Q
CCORG ;COST CENTER/ORGANIZATION look-up and counter initialization
S (FTP,PTP,PTPFTE,FTT,PTT,PTTFTE,INT,INTFTE,TSR,TSRFTE,SIS,TOT,FTETOT,LWOP,FEE)=0
S (MDFTP,MDPTP,MDPTPFTE,MDFTT,MDPTT,MDPTTFTE,MDINT,MDINTFTE,MDTSR,MDTSRFTE,MDSIS,MDTOT,MDFTETOT,MDLWOP,MDFEE)=0
S (RNFTP,RNPTP,RNPTPFTE,RNFTT,RNPTT,RNPTTFTE,RNINT,RNINTFTE,RNTSR,RNTSRFTE,RNSIS,RNTOT,RNFTETOT,RNLWOP,RNFEE)=0
S (LPFTP,LPPTP,LPPTPFTE,LPFTT,LPPTT,LPPTTFTE,LPINT,LPINTFTE,LPTSR,LPTSRFTE,LPSIS,LPTOT,LPFTETOT,LPLWOP,LPFEE)=0
S (NAFTP,NAPTP,NAPTPFTE,NAFTT,NAPTT,NAPTTFTE,NAINT,NAINTFTE,NATSR,NATSRFTE,NASIS,NATOT,NAFTETOT,NALWOP,NAFEE)=0
S (GPY,GPYTOT,PRJSAL)=0
S CCORG1=$E(CCORG,1,4)_":"_$E(CCORG,5,8)
S CCORGIEN=0,CCORGIEN=$O(^PRSP(454,1,"ORG","B",CCORG1,CCORGIEN))
I CCORGIEN="" S CCORGPT=MISCIEN,CCORGNAM="MISCELLANEOUS",^XTMP("CCORG",CCORG1)="" Q
S CCORGPT=$P(^PRSP(454,1,"ORG",CCORGIEN,0),U,2)
I CCORGPT="" S CCORGPT=MISCIEN,^XTMP("CCORG",CCORG1)=""
I $D(^PRSP(454.1,CCORGPT,0)) S CCORGNAM=$P(^PRSP(454.1,CCORGPT,0),U,1) Q
S CCORGPT=MISCIEN,CCORGNAM="MISCELLANEOUS",^XTMP("CCORG",CCORG1)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDSRC 3916 printed Apr 09, 2024@21:31:43 Page 2
PRSDSRC ;HISC/GWB-STRENGTH REPORT COMPILATION ;8/23/93 15:34
+1 ;;4.0;PAID;**6,101**;Sep 21, 1995
TASK SET %=0
WRITE !!,"Do you wish to queue this job"
DO YN^DICN
+1 IF %=-1
GOTO EXIT
+2 IF %=0
WRITE !!,"Answer 'Y' if you wish this job to be run as a background job.",!,"Answer 'N' if you wish this job to be run interactively."
GOTO TASK
ASKDEV IF %=1
SET %ZIS="QMN"
SET %ZIS("B")=""
SET OUT=""
DO ^%ZIS
if POP
GOTO EXIT
Begin DoDot:1
+1 IF IO=IO(0)
IF $EXTRACT(IOST,1)="C"
WRITE !,*7,"Please select a device other than your home device.",!
SET OUT="Y"
QUIT
+2 IF $DATA(IO("S"))
WRITE !,*7,"Please select a device other than a slave device.",!
SET OUT="Y"
QUIT
+3 IF IOM<132
WRITE !,*7,"Please select a right margin of at least 132.",!
SET OUT="Y"
QUIT
+4 SET ZTRTN="START^PRSDSRC"
SET ZTDESC="PAID STRENGTH REPORT"
+5 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
QUIT
End DoDot:1
if OUT="Y"
GOTO ASKDEV
GOTO EXIT
START DO NOW^%DTC
SET COMPDT=$JUSTIFY(%,"",4)
+1 SET MISCIEN=0
SET MISCIEN=$ORDER(^PRSP(454.1,"B","MISCELLANEOUS",MISCIEN))
+2 DO INIT
+3 SET CCORG=""
FOR
SET CCORG=$ORDER(^PRSPC("ACC",CCORG))
if CCORG'>0
QUIT
if '$DATA(ZTSK)
WRITE "."
DO CCORG
SET IEN=0
FOR
SET IEN=$ORDER(^PRSPC("ACC",CCORG,IEN))
if IEN'>0
DO ^PRSDSRC1
if IEN'>0
QUIT
DO CATCNT
if '$DATA(NOSUB)
DO SUBCAT
KILL NOSUB
PRINT IF $DATA(ZTQUEUED)
DO START^PRSDSRP
GOTO EXIT
+1 DO ^PRSDSRP
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^XTMP("CCORG")
DO KILL^XUSCLEAN
QUIT
CATCNT SET ZERO=^PRSPC(IEN,0)
+1 SET ONE=^PRSPC(IEN,1)
+2 SET ASN=$PIECE(ZERO,U,4)
SET DBS=$PIECE(ZERO,U,10)
SET OST=$PIECE(ZERO,U,17)
+3 SET OCC=$EXTRACT($PIECE(ZERO,U,17),1,4)
SET PBS=$PIECE(ZERO,U,20)
SET PPL=$PIECE(ZERO,U,21)
+4 SET SAL=$PIECE(ZERO,U,29)
SET TOA=$PIECE(ZERO,U,43)
+5 SET FTE=$PIECE($GET(^PRSPC(IEN,"MISC4")),U,11)
+6 SET GPY=$PIECE($GET(^PRSPC(IEN,"MEDICARE")),U,6)
+7 SET ITR=$PIECE($GET(^PRSPC(IEN,"T38")),U,15)
+8 SET LWOPIND=$PIECE($GET(^PRSPC(IEN,"LWOP")),U,1)
+9 SET SAL=$SELECT("2EF457X"[PBS:SAL*2087,1:SAL)
+10 SET GPYTOT=GPYTOT+GPY
SET PRJSAL=PRJSAL+SAL
+11 IF PPL="F"
IF $EXTRACT($PIECE(ONE,U,33),1)'="Y"
SET FEE=FEE+1
QUIT
+12 IF LWOPIND="Y"
SET LWOP=LWOP+1
+13 IF ($EXTRACT(ASN,1)="T")!($EXTRACT(ASN,1)="A")!(OST="060552")!(OST="060556")!(OST="061071")!(OST="061072")!(OST="061080")!(OST="061083")!(OST="063160")!(PBS="S")!(ITR>0)
SET TSR=TSR+1
SET TSRFTE=TSRFTE+FTE
SET NOSUB=""
QUIT
+14 SET TOT=TOT+1
SET FTETOT=FTETOT+FTE
+15 IF "12579DRSWMNEAHUF"[TOA
if DBS=1
SET FTP=FTP+1
if DBS=2
SET PTP=PTP+1
SET PTPFTE=PTPFTE+FTE
if DBS=3
SET INT=INT+1
SET INTFTE=INTFTE+FTE
QUIT
+16 IF "3468JKLTVPZ"[TOA
if DBS=1
SET FTT=FTT+1
if DBS=2
SET PTT=PTT+1
SET PTTFTE=PTTFTE+FTE
if DBS=3
SET INT=INT+1
SET INTFTE=INTFTE+FTE
QUIT
+17 IF "XY"[TOA
SET SIS=SIS+1
SET INTFTE=INTFTE+FTE
QUIT
+18 IF DBS=3
SET INT=INT+1
SET INTFTE=INTFTE+FTE
QUIT
+19 QUIT
SUBCAT IF (OCC="0602")!(OCC="0680")!(OCC="0662")!(OCC="0668")
DO MD^PRSDSRC2
QUIT
+1 if CCORGNAM'="NURSING"
QUIT
+2 IF OCC="0610"
DO RN^PRSDSRC2
QUIT
+3 IF OCC="0620"
DO LP^PRSDSRC2
QUIT
+4 IF OCC="0621"
DO NA^PRSDSRC2
QUIT
+5 QUIT
INIT SET CCORGIEN=0
FOR
SET CCORGIEN=$ORDER(^PRSP(454.1,CCORGIEN))
if CCORGIEN'>0
QUIT
Begin DoDot:1
+1 SET $PIECE(^PRSP(454.1,CCORGIEN,0),U,3)=""
+2 SET ^PRSP(454.1,CCORGIEN,1)=""
SET ^PRSP(454.1,CCORGIEN,2)=""
+3 SET ^PRSP(454.1,CCORGIEN,3)=""
SET ^PRSP(454.1,CCORGIEN,4)=""
+4 SET ^PRSP(454.1,CCORGIEN,5)=""
SET ^PRSP(454.1,CCORGIEN,6)=""
End DoDot:1
+5 KILL ^XTMP("CCORG")
+6 QUIT
CCORG ;COST CENTER/ORGANIZATION look-up and counter initialization
+1 SET (FTP,PTP,PTPFTE,FTT,PTT,PTTFTE,INT,INTFTE,TSR,TSRFTE,SIS,TOT,FTETOT,LWOP,FEE)=0
+2 SET (MDFTP,MDPTP,MDPTPFTE,MDFTT,MDPTT,MDPTTFTE,MDINT,MDINTFTE,MDTSR,MDTSRFTE,MDSIS,MDTOT,MDFTETOT,MDLWOP,MDFEE)=0
+3 SET (RNFTP,RNPTP,RNPTPFTE,RNFTT,RNPTT,RNPTTFTE,RNINT,RNINTFTE,RNTSR,RNTSRFTE,RNSIS,RNTOT,RNFTETOT,RNLWOP,RNFEE)=0
+4 SET (LPFTP,LPPTP,LPPTPFTE,LPFTT,LPPTT,LPPTTFTE,LPINT,LPINTFTE,LPTSR,LPTSRFTE,LPSIS,LPTOT,LPFTETOT,LPLWOP,LPFEE)=0
+5 SET (NAFTP,NAPTP,NAPTPFTE,NAFTT,NAPTT,NAPTTFTE,NAINT,NAINTFTE,NATSR,NATSRFTE,NASIS,NATOT,NAFTETOT,NALWOP,NAFEE)=0
+6 SET (GPY,GPYTOT,PRJSAL)=0
+7 SET CCORG1=$EXTRACT(CCORG,1,4)_":"_$EXTRACT(CCORG,5,8)
+8 SET CCORGIEN=0
SET CCORGIEN=$ORDER(^PRSP(454,1,"ORG","B",CCORG1,CCORGIEN))
+9 IF CCORGIEN=""
SET CCORGPT=MISCIEN
SET CCORGNAM="MISCELLANEOUS"
SET ^XTMP("CCORG",CCORG1)=""
QUIT
+10 SET CCORGPT=$PIECE(^PRSP(454,1,"ORG",CCORGIEN,0),U,2)
+11 IF CCORGPT=""
SET CCORGPT=MISCIEN
SET ^XTMP("CCORG",CCORG1)=""
+12 IF $DATA(^PRSP(454.1,CCORGPT,0))
SET CCORGNAM=$PIECE(^PRSP(454.1,CCORGPT,0),U,1)
QUIT
+13 SET CCORGPT=MISCIEN
SET CCORGNAM="MISCELLANEOUS"
SET ^XTMP("CCORG",CCORG1)=""
+14 QUIT
