source: FOIAVistA/trunk/r/PAID-PRS/PRSDSRC.m@ 1394

Last change on this file since 1394 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

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