Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSDSRC

PRSDSRC.m

Go to the documentation of this file.
  1. PRSDSRC ;HISC/GWB-STRENGTH REPORT COMPILATION ;8/23/93 15:34
  1. ;;4.0;PAID;**6,101**;Sep 21, 1995
  1. TASK S %=0 W !!,"Do you wish to queue this job" D YN^DICN
  1. I %=-1 G EXIT
  1. 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
  1. ASKDEV I %=1 S %ZIS="QMN",%ZIS("B")="",OUT="" D ^%ZIS G EXIT:POP D G:OUT="Y" ASKDEV G EXIT
  1. .I IO=IO(0),$E(IOST,1)="C" W !,*7,"Please select a device other than your home device.",! S OUT="Y" Q
  1. .I $D(IO("S")) W !,*7,"Please select a device other than a slave device.",! S OUT="Y" Q
  1. .I IOM<132 W !,*7,"Please select a right margin of at least 132.",! S OUT="Y" Q
  1. .S ZTRTN="START^PRSDSRC",ZTDESC="PAID STRENGTH REPORT"
  1. .D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q
  1. START D NOW^%DTC S COMPDT=$J(%,"",4)
  1. S MISCIEN=0,MISCIEN=$O(^PRSP(454.1,"B","MISCELLANEOUS",MISCIEN))
  1. D INIT
  1. 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
  1. PRINT I $D(ZTQUEUED) D START^PRSDSRP G EXIT
  1. D ^PRSDSRP
  1. EXIT S:$D(ZTQUEUED) ZTREQ="@" K ^XTMP("CCORG") D KILL^XUSCLEAN Q
  1. CATCNT S ZERO=^PRSPC(IEN,0)
  1. S ONE=^PRSPC(IEN,1)
  1. S ASN=$P(ZERO,U,4),DBS=$P(ZERO,U,10),OST=$P(ZERO,U,17)
  1. S OCC=$E($P(ZERO,U,17),1,4),PBS=$P(ZERO,U,20),PPL=$P(ZERO,U,21)
  1. S SAL=$P(ZERO,U,29),TOA=$P(ZERO,U,43)
  1. S FTE=$P($G(^PRSPC(IEN,"MISC4")),U,11)
  1. S GPY=$P($G(^PRSPC(IEN,"MEDICARE")),U,6)
  1. S ITR=$P($G(^PRSPC(IEN,"T38")),U,15)
  1. S LWOPIND=$P($G(^PRSPC(IEN,"LWOP")),U,1)
  1. S SAL=$S("2EF457X"[PBS:SAL*2087,1:SAL)
  1. S GPYTOT=GPYTOT+GPY,PRJSAL=PRJSAL+SAL
  1. I PPL="F",$E($P(ONE,U,33),1)'="Y" S FEE=FEE+1 Q
  1. I LWOPIND="Y" S LWOP=LWOP+1
  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
  1. S TOT=TOT+1,FTETOT=FTETOT+FTE
  1. 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
  1. 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
  1. I "XY"[TOA S SIS=SIS+1,INTFTE=INTFTE+FTE Q
  1. I DBS=3 S INT=INT+1,INTFTE=INTFTE+FTE Q
  1. Q
  1. SUBCAT I (OCC="0602")!(OCC="0680")!(OCC="0662")!(OCC="0668") D MD^PRSDSRC2 Q
  1. Q:CCORGNAM'="NURSING"
  1. I OCC="0610" D RN^PRSDSRC2 Q
  1. I OCC="0620" D LP^PRSDSRC2 Q
  1. I OCC="0621" D NA^PRSDSRC2 Q
  1. Q
  1. INIT S CCORGIEN=0 F S CCORGIEN=$O(^PRSP(454.1,CCORGIEN)) Q:CCORGIEN'>0 D
  1. .S $P(^PRSP(454.1,CCORGIEN,0),U,3)=""
  1. .S ^PRSP(454.1,CCORGIEN,1)="",^PRSP(454.1,CCORGIEN,2)=""
  1. .S ^PRSP(454.1,CCORGIEN,3)="",^PRSP(454.1,CCORGIEN,4)=""
  1. .S ^PRSP(454.1,CCORGIEN,5)="",^PRSP(454.1,CCORGIEN,6)=""
  1. K ^XTMP("CCORG")
  1. Q
  1. CCORG ;COST CENTER/ORGANIZATION look-up and counter initialization
  1. S (FTP,PTP,PTPFTE,FTT,PTT,PTTFTE,INT,INTFTE,TSR,TSRFTE,SIS,TOT,FTETOT,LWOP,FEE)=0
  1. S (MDFTP,MDPTP,MDPTPFTE,MDFTT,MDPTT,MDPTTFTE,MDINT,MDINTFTE,MDTSR,MDTSRFTE,MDSIS,MDTOT,MDFTETOT,MDLWOP,MDFEE)=0
  1. S (RNFTP,RNPTP,RNPTPFTE,RNFTT,RNPTT,RNPTTFTE,RNINT,RNINTFTE,RNTSR,RNTSRFTE,RNSIS,RNTOT,RNFTETOT,RNLWOP,RNFEE)=0
  1. S (LPFTP,LPPTP,LPPTPFTE,LPFTT,LPPTT,LPPTTFTE,LPINT,LPINTFTE,LPTSR,LPTSRFTE,LPSIS,LPTOT,LPFTETOT,LPLWOP,LPFEE)=0
  1. S (NAFTP,NAPTP,NAPTPFTE,NAFTT,NAPTT,NAPTTFTE,NAINT,NAINTFTE,NATSR,NATSRFTE,NASIS,NATOT,NAFTETOT,NALWOP,NAFEE)=0
  1. S (GPY,GPYTOT,PRJSAL)=0
  1. S CCORG1=$E(CCORG,1,4)_":"_$E(CCORG,5,8)
  1. S CCORGIEN=0,CCORGIEN=$O(^PRSP(454,1,"ORG","B",CCORG1,CCORGIEN))
  1. I CCORGIEN="" S CCORGPT=MISCIEN,CCORGNAM="MISCELLANEOUS",^XTMP("CCORG",CCORG1)="" Q
  1. S CCORGPT=$P(^PRSP(454,1,"ORG",CCORGIEN,0),U,2)
  1. I CCORGPT="" S CCORGPT=MISCIEN,^XTMP("CCORG",CCORG1)=""
  1. I $D(^PRSP(454.1,CCORGPT,0)) S CCORGNAM=$P(^PRSP(454.1,CCORGPT,0),U,1) Q
  1. S CCORGPT=MISCIEN,CCORGNAM="MISCELLANEOUS",^XTMP("CCORG",CCORG1)=""
  1. Q