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