- 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 Feb 18, 2025@23:52:33 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