- ECTP1S0 ;B'ham ISC/PTD-PAID Data for One Service - CONTINUED ;01/29/91 08:00
- V ;;1.05;INTERIM MANAGEMENT SUPPORT;**4,8,10**;
- ENQ ;ENTRY POINT WHEN QUEUED
- K ^TMP($J) S YP=(BYRPP-1)
- LP1 ;LOOP THROUGH DATE/PAY PERIOD REQUESTED
- F J=0:0 S YP=$O(^PRST(455,YP)) G:'YP EN1^ECTP1S1 G:YP>EYRPP EN1^ECTP1S1 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^ECTPAS0 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECTP1S0 2639 printed Jan 18, 2025@03:03:43 Page 2
- ECTP1S0 ;B'ham ISC/PTD-PAID Data for One Service - 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 YP=(BYRPP-1)
- LP1 ;LOOP THROUGH DATE/PAY PERIOD REQUESTED
- +1 FOR J=0:0
- SET YP=$ORDER(^PRST(455,YP))
- if 'YP
- GOTO EN1^ECTP1S1
- if YP>EYRPP
- GOTO EN1^ECTP1S1
- 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 ;
- 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^ECTPAS0
- 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 ;