ECTPAS0 ;B'ham ISC/PTD-PAID Data for All Services - CONTINUED ;01/29/91 08:00
V ;;1.05;INTERIM MANAGEMENT SUPPORT;**4,8,10**;
ENQ ;ENTRY POINT WHEN QUEUED
K ^TMP($J) S SRVDA=0
LP1 ;LOOP THROUGH ALL 'LOCAL' SERVICES AND THROUGH DATE/PAY PERIOD REQUESTED
F L=0:0 S SRVDA=$O(^ECC(730,"ALS",SRVDA)) G:'SRVDA EN1^ECTPAS1 S YP=(BYRPP-1) F J=0:0 S YP=$O(^PRST(455,YP)) Q:'YP Q:YP>EYRPP S (EMPDA,PAL,PSL,PLWOP,PAA,PCTE,PCTU,PUNS,POT)=0 D LP2 D:$D(TMP(SRVDA,YP)) SETGL
;
LP2 ;LOOP THROUGH ALL RECORDS FOR DATE/PAY PERIOD
Q:'$O(^PRST(455,YP,0))
EMP F K=0:0 S EMPDA=$O(^PRST(455,YP,1,EMPDA)) Q:'EMPDA S TL=$P(^PRST(455,YP,1,EMPDA,0),"^",7) G:TL="" EMP G:'$D(SRVTL(SRVDA,TL)) EMP D GTDTA
Q
;
;
GTDTA ;FOR SELECTED PAY PERIOD, EXTRACT DATA FOR INDIVIDUAL
I '$D(^PRST(455,YP,1,EMPDA,1)) S LOC0=^PRST(455,YP,1,EMPDA,0) F PC=1,2,3,6,7,11,12,13,17,18,19,47,48,49,50,51,53 S $P(LOC1,"^",PC)="000"
I G CALC
S LOC0=^PRST(455,YP,1,EMPDA,0),LOC1=^PRST(455,YP,1,EMPDA,1)
CALC ;COMPUTE FIRST AND SECOND WEEK TOTALS FOR PAY PERIOD
S (AL,SL,LWOP,AA,CTE,CTU,UNS,OT)=0
PHYS ;IS INDIVIDUAL FULL-TIME PHYSICIAN OR RESIDENT
I (($P(LOC0,"^",10)="J")!($P(LOC0,"^",10)="L")),($P(LOC0,"^",11)=1) D CONV G SETPP
AL S AL1=$P(LOC0,"^",13),AL2=$P(LOC0,"^",48),AL=(($E(AL1,3)/4)+($E(AL1,1,2))+($E(AL2,3)/4)+($E(AL2,1,2)))
SL S SL1=$P(LOC0,"^",14),SL2=$P(LOC0,"^",49),SL=(($E(SL1,3)/4)+($E(SL1,1,2))+($E(SL2,3)/4)+($E(SL2,1,2)))
LWOP S LWOP1=$P(LOC0,"^",15),LWOP2=$P(LOC0,"^",50),LWOP=(($E(LWOP1,3)/4)+($E(LWOP1,1,2))+($E(LWOP2,3)/4)+($E(LWOP2,1,2)))
AA S AA1=$P(LOC0,"^",17),AA2=$P(LOC0,"^",52),AA=(($E(AA1,3)/4)+($E(AA1,1,2))+($E(AA2,3)/4)+($E(AA2,1,2)))
CTE S CTE1=$P(LOC0,"^",19),CTE2=$P(LOC1,"^"),CTE=(($E(CTE1,3)/4)+($E(CTE1,1,2))+($E(CTE2,3)/4)+($E(CTE2,1,2)))
CTU S CTU1=$P(LOC0,"^",20),CTU2=$P(LOC1,"^",2),CTU=(($E(CTU1,3)/4)+($E(CTU1,1,2))+($E(CTU2,3)/4)+($E(CTU2,1,2)))
UNS S UNS1=$P(LOC0,"^",21),UNS2=$P(LOC1,"^",3),UNS=(($E(UNS1,3)/4)+($E(UNS1,1,2))+($E(UNS2,3)/4)+($E(UNS2,1,2)))
OT S (OT1,OT2)=0 F PC=25,29,30,31,33,35,36,37 S OT1=OT1+$P(LOC0,"^",PC) I $E(OT1,$L(OT1))>3 S OT1=OT1+6
F PC=6,7,49 S OT1=OT1+$P(LOC1,"^",PC) I $E(OT1,$L(OT1))>3 S OT1=OT1+6
F PC=11,12,13,17,18,19,47,48,50,51,53 S OT2=OT2+$P(LOC1,"^",PC) I $E(OT2,$L(OT2))>3 S OT2=OT2+6
S OT1=$E("000",1,3-$L(OT1))_OT1,OT2=$E("000",1,3-$L(OT2))_OT2,OT=(($E(OT1,3)/4)+($E(OT1,1,2))+($E(OT2,3)/4)+($E(OT2,1,2)))
SETPP ;INCREMENT PAY PERIOD COUNTERS FOR THIS INDIVIDUAL
S PAL=PAL+AL,PSL=PSL+SL,PLWOP=PLWOP+LWOP,PAA=PAA+AA,PCTE=PCTE+CTE,PCTU=PCTU+CTU,PUNS=PUNS+UNS,POT=POT+OT
S TMP(SRVDA,YP)=PAL_"^"_PSL_"^"_PLWOP_"^"_PAA_"^"_PCTE_"^"_PCTU_"^"_PUNS_"^"_POT
Q
;
SETGL ;SET TMP GLOBAL
S ^TMP($J,SRVDA,YP)=TMP(SRVDA,YP)
Q
;
CONV ;CONVERT LEAVE DAYS INTO HOURS
S X="",AL1=$E($P(LOC0,"^",13),2),AL2=$E($P(LOC0,"^",48),2),X=(((AL1+AL2)*40)/7) D RND S AL=X
S X="",SL1=$E($P(LOC0,"^",14),2),SL2=$E($P(LOC0,"^",49),2),X=(((SL1+SL2)*40)/7) D RND S SL=X
S X="",LWOP1=$E($P(LOC0,"^",15),2),LWOP2=$E($P(LOC0,"^",50),2),X=(((LWOP1+LWOP2)*40)/7) D RND S LWOP=X
S X="",AA1=$E($P(LOC0,"^",17),2),AA2=$E($P(LOC0,"^",52),2),X=(((AA1+AA2)*40)/7) D RND S AA=X
Q
;
RND ;ROUND TO NEAREST QUARTER HOUR
S FR=$E($P(X,".",2),1,2),WH=$P(X,".")
S FR=$S((FR<13):0,((FR>12)&(FR<38)):25,((FR>37)&(FR<63)):5,((FR>62)&(FR<88)):75,1:"Z") I FR="Z" S FR=0,WH=WH+1
S X=WH_"."_FR
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECTPAS0 3368 printed Apr 09, 2024@21:05:04 Page 2
ECTPAS0 ;B'ham ISC/PTD-PAID Data for All Services - CONTINUED ;01/29/91 08:00
V ;;1.05;INTERIM MANAGEMENT SUPPORT;**4,8,10**;
ENQ ;ENTRY POINT WHEN QUEUED
+1 KILL ^TMP($JOB)
SET SRVDA=0
LP1 ;LOOP THROUGH ALL 'LOCAL' SERVICES AND THROUGH DATE/PAY PERIOD REQUESTED
+1 FOR L=0:0
SET SRVDA=$ORDER(^ECC(730,"ALS",SRVDA))
if 'SRVDA
GOTO EN1^ECTPAS1
SET YP=(BYRPP-1)
FOR J=0:0
SET YP=$ORDER(^PRST(455,YP))
if 'YP
QUIT
if YP>EYRPP
QUIT
SET (EMPDA,PAL,PSL,PLWOP,PAA,PCTE,PCTU,PUNS,POT)=0
DO LP2
if $DATA(TMP(SRVDA,YP))
DO SETGL
+2 ;
LP2 ;LOOP THROUGH ALL RECORDS FOR DATE/PAY PERIOD
+1 if '$ORDER(^PRST(455,YP,0))
QUIT
EMP FOR K=0:0
SET EMPDA=$ORDER(^PRST(455,YP,1,EMPDA))
if 'EMPDA
QUIT
SET TL=$PIECE(^PRST(455,YP,1,EMPDA,0),"^",7)
if TL=""
GOTO EMP
if '$DATA(SRVTL(SRVDA,TL))
GOTO EMP
DO GTDTA
+1 QUIT
+2 ;
+3 ;
GTDTA ;FOR SELECTED PAY PERIOD, EXTRACT DATA FOR INDIVIDUAL
+1 IF '$DATA(^PRST(455,YP,1,EMPDA,1))
SET LOC0=^PRST(455,YP,1,EMPDA,0)
FOR PC=1,2,3,6,7,11,12,13,17,18,19,47,48,49,50,51,53
SET $PIECE(LOC1,"^",PC)="000"
+2 IF $TEST
GOTO CALC
+3 SET LOC0=^PRST(455,YP,1,EMPDA,0)
SET LOC1=^PRST(455,YP,1,EMPDA,1)
CALC ;COMPUTE FIRST AND SECOND WEEK TOTALS FOR PAY PERIOD
+1 SET (AL,SL,LWOP,AA,CTE,CTU,UNS,OT)=0
PHYS ;IS INDIVIDUAL FULL-TIME PHYSICIAN OR RESIDENT
+1 IF (($PIECE(LOC0,"^",10)="J")!($PIECE(LOC0,"^",10)="L"))
IF ($PIECE(LOC0,"^",11)=1)
DO CONV
GOTO SETPP
AL SET AL1=$PIECE(LOC0,"^",13)
SET AL2=$PIECE(LOC0,"^",48)
SET AL=(($EXTRACT(AL1,3)/4)+($EXTRACT(AL1,1,2))+($EXTRACT(AL2,3)/4)+($EXTRACT(AL2,1,2)))
SL SET SL1=$PIECE(LOC0,"^",14)
SET SL2=$PIECE(LOC0,"^",49)
SET SL=(($EXTRACT(SL1,3)/4)+($EXTRACT(SL1,1,2))+($EXTRACT(SL2,3)/4)+($EXTRACT(SL2,1,2)))
LWOP SET LWOP1=$PIECE(LOC0,"^",15)
SET LWOP2=$PIECE(LOC0,"^",50)
SET LWOP=(($EXTRACT(LWOP1,3)/4)+($EXTRACT(LWOP1,1,2))+($EXTRACT(LWOP2,3)/4)+($EXTRACT(LWOP2,1,2)))
AA SET AA1=$PIECE(LOC0,"^",17)
SET AA2=$PIECE(LOC0,"^",52)
SET AA=(($EXTRACT(AA1,3)/4)+($EXTRACT(AA1,1,2))+($EXTRACT(AA2,3)/4)+($EXTRACT(AA2,1,2)))
CTE SET CTE1=$PIECE(LOC0,"^",19)
SET CTE2=$PIECE(LOC1,"^")
SET CTE=(($EXTRACT(CTE1,3)/4)+($EXTRACT(CTE1,1,2))+($EXTRACT(CTE2,3)/4)+($EXTRACT(CTE2,1,2)))
CTU SET CTU1=$PIECE(LOC0,"^",20)
SET CTU2=$PIECE(LOC1,"^",2)
SET CTU=(($EXTRACT(CTU1,3)/4)+($EXTRACT(CTU1,1,2))+($EXTRACT(CTU2,3)/4)+($EXTRACT(CTU2,1,2)))
UNS SET UNS1=$PIECE(LOC0,"^",21)
SET UNS2=$PIECE(LOC1,"^",3)
SET UNS=(($EXTRACT(UNS1,3)/4)+($EXTRACT(UNS1,1,2))+($EXTRACT(UNS2,3)/4)+($EXTRACT(UNS2,1,2)))
OT SET (OT1,OT2)=0
FOR PC=25,29,30,31,33,35,36,37
SET OT1=OT1+$PIECE(LOC0,"^",PC)
IF $EXTRACT(OT1,$LENGTH(OT1))>3
SET OT1=OT1+6
+1 FOR PC=6,7,49
SET OT1=OT1+$PIECE(LOC1,"^",PC)
IF $EXTRACT(OT1,$LENGTH(OT1))>3
SET OT1=OT1+6
+2 FOR PC=11,12,13,17,18,19,47,48,50,51,53
SET OT2=OT2+$PIECE(LOC1,"^",PC)
IF $EXTRACT(OT2,$LENGTH(OT2))>3
SET OT2=OT2+6
+3 SET OT1=$EXTRACT("000",1,3-$LENGTH(OT1))_OT1
SET OT2=$EXTRACT("000",1,3-$LENGTH(OT2))_OT2
SET OT=(($EXTRACT(OT1,3)/4)+($EXTRACT(OT1,1,2))+($EXTRACT(OT2,3)/4)+($EXTRACT(OT2,1,2)))
SETPP ;INCREMENT PAY PERIOD COUNTERS FOR THIS INDIVIDUAL
+1 SET PAL=PAL+AL
SET PSL=PSL+SL
SET PLWOP=PLWOP+LWOP
SET PAA=PAA+AA
SET PCTE=PCTE+CTE
SET PCTU=PCTU+CTU
SET PUNS=PUNS+UNS
SET POT=POT+OT
+2 SET TMP(SRVDA,YP)=PAL_"^"_PSL_"^"_PLWOP_"^"_PAA_"^"_PCTE_"^"_PCTU_"^"_PUNS_"^"_POT
+3 QUIT
+4 ;
SETGL ;SET TMP GLOBAL
+1 SET ^TMP($JOB,SRVDA,YP)=TMP(SRVDA,YP)
+2 QUIT
+3 ;
CONV ;CONVERT LEAVE DAYS INTO HOURS
+1 SET X=""
SET AL1=$EXTRACT($PIECE(LOC0,"^",13),2)
SET AL2=$EXTRACT($PIECE(LOC0,"^",48),2)
SET X=(((AL1+AL2)*40)/7)
DO RND
SET AL=X
+2 SET X=""
SET SL1=$EXTRACT($PIECE(LOC0,"^",14),2)
SET SL2=$EXTRACT($PIECE(LOC0,"^",49),2)
SET X=(((SL1+SL2)*40)/7)
DO RND
SET SL=X
+3 SET X=""
SET LWOP1=$EXTRACT($PIECE(LOC0,"^",15),2)
SET LWOP2=$EXTRACT($PIECE(LOC0,"^",50),2)
SET X=(((LWOP1+LWOP2)*40)/7)
DO RND
SET LWOP=X
+4 SET X=""
SET AA1=$EXTRACT($PIECE(LOC0,"^",17),2)
SET AA2=$EXTRACT($PIECE(LOC0,"^",52),2)
SET X=(((AA1+AA2)*40)/7)
DO RND
SET AA=X
+5 QUIT
+6 ;
RND ;ROUND TO NEAREST QUARTER HOUR
+1 SET FR=$EXTRACT($PIECE(X,".",2),1,2)
SET WH=$PIECE(X,".")
+2 SET FR=$SELECT((FR<13):0,((FR>12)&(FR<38)):25,((FR>37)&(FR<63)):5,((FR>62)&(FR<88)):75,1:"Z")
IF FR="Z"
SET FR=0
SET WH=WH+1
+3 SET X=WH_"."_FR
+4 QUIT
+5 ;
