source: FOIAVistA/tag/r/PAID-PRS/PRSDSRC.m@ 1104

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