- ECTPIND ;B'ham ISC/PTD-Individual PAID Inquiry ;01/29/91 08:00
- V ;;1.05;INTERIM MANAGEMENT SUPPORT;**4,8,10**;
- I '$D(^PRSPC) W *7,!!?29,"OPTION IS UNAVAILABLE!",!,"The 'Current Employee' File - #450 is not loaded on your system.",!! S XQUIT="" Q
- I '$O(^PRSPC(0)) W *7,!!,"'Current Employee' File - #450 has not been populated on your system.",!! S XQUIT="" Q
- I '$O(^PRST(455,0)) W *7,!!,"'Payperiod 8B' File - #455 has not been populated on your system.",!! S XQUIT="" Q
- DIC W !! S DIC="^PRSPC(",DIC(0)="QEANMZ",DIC("A")="Select EMPLOYEE name: " D ^DIC K DIC G:Y<0 EXIT^ECTPIND1 S EMPDA=+Y,NM=Y(0,0),EMPSN=$P(Y(0),"^",9)
- S FST=$O(^PRST(455,0)) W !!,"The earliest pay period/date in the file is: "_$E(FST,4,5)_" - '"_$E(FST,2,3)
- W !,"You may select the pay period/date RANGE:",!
- BPP R !,"Enter BEGINNING Pay Period: ",BPP:DTIME G:'$T!("^"[BPP) EXIT^ECTPIND1 I (BPP'?.N)!(BPP<1)!(BPP>27) W !!,"You MUST answer with a number between 1 and 27." G BPP
- S:$L(BPP)=1 BPP="0"_BPP
- BYR W ! S %DT="AE",%DT("A")="Enter calendar year associated with BEGINNING pay period: ",%DT(0)=2000000 D ^%DT G:$D(DTOUT)!("^"[X) EXIT^ECTPIND1 S BYR=$E(Y,1,3),BYRPP=BYR_BPP
- EPP R !!,"Enter ENDING Pay Period: ",EPP:DTIME G:'$T!("^"[EPP) EXIT^ECTPIND1 I (EPP'?.N)!(EPP<1)!(EPP>27) W !!,"You MUST answer with a number between 1 and 27." G EPP
- S:$L(EPP)=1 EPP="0"_EPP
- EYR W ! S %DT="AE",%DT("A")="Enter calendar year associated with ENDING pay period: ",%DT(0)=BYR_"0000" D ^%DT G:$D(DTOUT)!("^"[X) EXIT^ECTPIND1 S EYR=$E(Y,1,3),EYRPP=EYR_EPP
- I +BYRPP>+EYRPP W *7,!!?10,"ENDING pay period/date must be equal to",!?10,"or come after BEGINNING pay period/date!",!! K BPP,BYR,BYRPP,EPP,EYR,EYRPP G BPP
- PP S FLG=0,YP=(BYRPP-1) F J=0:0 S YP=$O(^PRST(455,"B",YP)) Q:'YP Q:YP>EYRPP S FLG=1 Q:FLG=1
- I FLG=0 W *7,!!,"There is NO DATA in the file for the selected date range!",!! G EXIT^ECTPIND1
- EMP S YP=(BYRPP-1),MS=0 F J=0:0 S YP=$O(^PRST(455,"B",YP)) Q:'YP Q:YP>EYRPP I '$O(^PRST(455,YP,1,EMPDA,0)) S MYP(YP)=""
- I $O(MYP(0)) W *7,!!,"There is NO DATA for SELECTED EMPLOYEE for pay period(s):"
- I F K=0:0 S MS=$O(MYP(MS)) Q:'MS W !?10,"'"_$E(MS,2,3)_" - "_$E(MS,4,5)
- I G EXIT^ECTPIND1
- DEV K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G EXIT^ECTPIND1
- I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^ECTPIND",ZTDESC="Individual PAID Inquiry" F G="EMPDA","NM","EMPSN","BYRPP","BYR","BPP","EYRPP","EYR","EPP" S:$D(@G) ZTSAVE(G)=""
- I D ^%ZTLOAD K ZTSK G EXIT^ECTPIND1
- U IO
- ;
- ENQ ;ENTRY PT
- K ^TMP($J) S YP=(BYRPP-1)
- F J=0:0 S YP=$O(^PRST(455,YP)) G:'YP EN1^ECTPIND1 G:YP>EYRPP EN1^ECTPIND1 D GTDTA
- ;
- GTDTA ;INDIV DATA FOR PP
- I '$D(^PRST(455,YP,1,EMPDA,0)) S ^TMP($J,YP)="" Q
- 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 TOTALS FOR PP
- S (AL,SL,LWOP,AA,CTE,CTU,OT)=0
- PHYS ;FULL-TIME PHYSICIAN/RESIDENT
- I (($P(LOC0,"^",10)="J")!($P(LOC0,"^",10)="L")),($P(LOC0,"^",11)=1) D CONV^ECTPAS0 G SETGL
- 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)))
- 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)))
- SETGL ;SET TMP GLOBAL
- S ^TMP($J,YP)=AL_"^"_SL_"^"_LWOP_"^"_AA_"^"_CTE_"^"_CTU_"^"_OT
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECTPIND 4300 printed Mar 13, 2025@21:07:29 Page 2
- ECTPIND ;B'ham ISC/PTD-Individual PAID Inquiry ;01/29/91 08:00
- V ;;1.05;INTERIM MANAGEMENT SUPPORT;**4,8,10**;
- +1 IF '$DATA(^PRSPC)
- WRITE *7,!!?29,"OPTION IS UNAVAILABLE!",!,"The 'Current Employee' File - #450 is not loaded on your system.",!!
- SET XQUIT=""
- QUIT
- +2 IF '$ORDER(^PRSPC(0))
- WRITE *7,!!,"'Current Employee' File - #450 has not been populated on your system.",!!
- SET XQUIT=""
- QUIT
- +3 IF '$ORDER(^PRST(455,0))
- WRITE *7,!!,"'Payperiod 8B' File - #455 has not been populated on your system.",!!
- SET XQUIT=""
- QUIT
- DIC WRITE !!
- SET DIC="^PRSPC("
- SET DIC(0)="QEANMZ"
- SET DIC("A")="Select EMPLOYEE name: "
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO EXIT^ECTPIND1
- SET EMPDA=+Y
- SET NM=Y(0,0)
- SET EMPSN=$PIECE(Y(0),"^",9)
- +1 SET FST=$ORDER(^PRST(455,0))
- WRITE !!,"The earliest pay period/date in the file is: "_$EXTRACT(FST,4,5)_" - '"_$EXTRACT(FST,2,3)
- +2 WRITE !,"You may select the pay period/date RANGE:",!
- BPP READ !,"Enter BEGINNING Pay Period: ",BPP:DTIME
- if '$TEST!("^"[BPP)
- GOTO EXIT^ECTPIND1
- IF (BPP'?.N)!(BPP<1)!(BPP>27)
- WRITE !!,"You MUST answer with a number between 1 and 27."
- GOTO BPP
- +1 if $LENGTH(BPP)=1
- SET BPP="0"_BPP
- BYR WRITE !
- SET %DT="AE"
- SET %DT("A")="Enter calendar year associated with BEGINNING pay period: "
- SET %DT(0)=2000000
- DO ^%DT
- if $DATA(DTOUT)!("^"[X)
- GOTO EXIT^ECTPIND1
- SET BYR=$EXTRACT(Y,1,3)
- SET BYRPP=BYR_BPP
- EPP READ !!,"Enter ENDING Pay Period: ",EPP:DTIME
- if '$TEST!("^"[EPP)
- GOTO EXIT^ECTPIND1
- IF (EPP'?.N)!(EPP<1)!(EPP>27)
- WRITE !!,"You MUST answer with a number between 1 and 27."
- GOTO EPP
- +1 if $LENGTH(EPP)=1
- SET EPP="0"_EPP
- EYR WRITE !
- SET %DT="AE"
- SET %DT("A")="Enter calendar year associated with ENDING pay period: "
- SET %DT(0)=BYR_"0000"
- DO ^%DT
- if $DATA(DTOUT)!("^"[X)
- GOTO EXIT^ECTPIND1
- SET EYR=$EXTRACT(Y,1,3)
- SET EYRPP=EYR_EPP
- +1 IF +BYRPP>+EYRPP
- WRITE *7,!!?10,"ENDING pay period/date must be equal to",!?10,"or come after BEGINNING pay period/date!",!!
- KILL BPP,BYR,BYRPP,EPP,EYR,EYRPP
- GOTO BPP
- PP SET FLG=0
- SET YP=(BYRPP-1)
- FOR J=0:0
- SET YP=$ORDER(^PRST(455,"B",YP))
- if 'YP
- QUIT
- if YP>EYRPP
- QUIT
- SET FLG=1
- if FLG=1
- QUIT
- +1 IF FLG=0
- WRITE *7,!!,"There is NO DATA in the file for the selected date range!",!!
- GOTO EXIT^ECTPIND1
- EMP SET YP=(BYRPP-1)
- SET MS=0
- FOR J=0:0
- SET YP=$ORDER(^PRST(455,"B",YP))
- if 'YP
- QUIT
- if YP>EYRPP
- QUIT
- IF '$ORDER(^PRST(455,YP,1,EMPDA,0))
- SET MYP(YP)=""
- +1 IF $ORDER(MYP(0))
- WRITE *7,!!,"There is NO DATA for SELECTED EMPLOYEE for pay period(s):"
- +2 IF $TEST
- FOR K=0:0
- SET MS=$ORDER(MYP(MS))
- if 'MS
- QUIT
- WRITE !?10,"'"_$EXTRACT(MS,2,3)_" - "_$EXTRACT(MS,4,5)
- +3 IF $TEST
- GOTO EXIT^ECTPIND1
- DEV KILL %ZIS,IOP
- SET %ZIS="QM"
- SET %ZIS("B")=""
- DO ^%ZIS
- IF POP
- WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
- GOTO EXIT^ECTPIND1
- +1 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="ENQ^ECTPIND"
- SET ZTDESC="Individual PAID Inquiry"
- FOR G="EMPDA","NM","EMPSN","BYRPP","BYR","BPP","EYRPP","EYR","EPP"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +2 IF $TEST
- DO ^%ZTLOAD
- KILL ZTSK
- GOTO EXIT^ECTPIND1
- +3 USE IO
- +4 ;
- ENQ ;ENTRY PT
- +1 KILL ^TMP($JOB)
- SET YP=(BYRPP-1)
- +2 FOR J=0:0
- SET YP=$ORDER(^PRST(455,YP))
- if 'YP
- GOTO EN1^ECTPIND1
- if YP>EYRPP
- GOTO EN1^ECTPIND1
- DO GTDTA
- +3 ;
- GTDTA ;INDIV DATA FOR PP
- +1 IF '$DATA(^PRST(455,YP,1,EMPDA,0))
- SET ^TMP($JOB,YP)=""
- QUIT
- +2 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"
- +3 IF $TEST
- GOTO CALC
- +4 SET LOC0=^PRST(455,YP,1,EMPDA,0)
- SET LOC1=^PRST(455,YP,1,EMPDA,1)
- CALC ;COMPUTE TOTALS FOR PP
- +1 SET (AL,SL,LWOP,AA,CTE,CTU,OT)=0
- PHYS ;FULL-TIME PHYSICIAN/RESIDENT
- +1 IF (($PIECE(LOC0,"^",10)="J")!($PIECE(LOC0,"^",10)="L"))
- IF ($PIECE(LOC0,"^",11)=1)
- DO CONV^ECTPAS0
- GOTO SETGL
- 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)))
- 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)))
- SETGL ;SET TMP GLOBAL
- +1 SET ^TMP($JOB,YP)=AL_"^"_SL_"^"_LWOP_"^"_AA_"^"_CTE_"^"_CTU_"^"_OT
- +2 QUIT
- +3 ;
