- PRS8SU ;HISC/MRL-DECOMPOSITION, SET-UP ;02/20/08
- ;;4.0;PAID;**112,116**;Sep 21, 1995;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;This routine sets up various data elements required to process
- ;a decomp. The ^TMP array is built for each day of the
- ;pay period (1-14) and includes tour information, exceptions,
- ;holiday information, etc. All times are converted to 15-minute
- ;increments in this routine (the number of 15-minute increments
- ;into the day). Additionally, the credit tour for WG
- ;employees is determined in this routine.
- ;
- ;Called by Routines: PRS8DR
- ;
- K ^TMP($J,"PRS8")
- K D,DAY F DAY=0:1:15 D
- .I 'CYA,DAY>1,DAY<15,$E($P(PPD,"^",DAY),4,7)="0101" S CYA=DAY
- .S P=0 I 'DAY S P=+PPD(0),D=14 ;last day of previous pp
- .I DAY=15 S P=+PPD(15),D=1 ;first day of next pp
- .I P S ZZ=$S(D=14:0,1:15)
- .I 'P S P=+PY,(ZZ,D)=+DAY
- .S W=$S(D<8:1,1:2) K DADRFM S DADRFM=1
- .S TWO=0 F N=0,1,4,2,10 S Z=$G(^PRST(458,+P,"E",+DFN,"D",+D,N)) D
- ..S (N14,NDAY,LAST,QT)=0,D(N)=Z,N1=$S(N=2:4,1:3)
- ..I N=0,$S(ZZ<15:1,1:0) F J=2,13 I +$P(D(0),"^",J) D
- ...S X=+$P(D(0),"^",$S(J=2:8,1:14)) Q:'X ;normal hours
- ...I DAY'=0 S X=X\.25 S NH(W)=NH(W)+X ;increment NH
- ...S Z1=Z,Z=X,D1=D,X="DH"_$S(J=2:1,1:2) D SET S Z=Z1 ;save NH
- ...S X=+$P(D(0),"^",J)
- ...S X=+$P($G(^PRST(457.1,+X,0)),"^",3) Q:'X ;mltime
- ...S X=X\15,MT($S(J=2:1,1:2))=X ;save mltime
- ...I X S X1=Z,Z=X,D1=D,X="MT"_$S(J=2:1,1:2) D SET S Z=X1
- ..I "^1^2^4^"[("^"_N_"^") F K=1:N1 S V=$P(Z,"^",K,K+1) Q:QT D
- ...S X=$P(Z,U,K,999) S:X?1"^"."^"!(X="")!(N14=1) QT=1 I QT!($P(Z,U,K)="") Q
- ...S:K=1 (NDAY,LAST)=0 F K1=1,2 S X=$P(V,"^",K1),(Y,Y1)=K1-1 I X'="" D
- ....S FLAG=1 I N=2&(K1=1)&("^HW^"[("^"_$P(Z,"^",K+2)_"^")) S FLAG=$S(NDAY=1!(LAST>96)&("^HW^"[("^"_$P(Z,"^",K+2)_"^"))&((X["A")!(X["MID")):0,1:1),NDAY=0
- ....S:$P(D(0),"^",14)'=""&(X="MID")&(LAST=96)&(N=2)&(K1=1) FLAG=0 S:N=2&(K1=1)&(FLAG=1) (NDAY,LAST)=0 S Y=K1-1 D 15
- ....I N=2,"^RG^OT^CT^ON^SB^"'[("^"_$P(Z,"^",K+2)_"^") D
- .....S Y=+$O(DADRFM("S",(-X-.01))),Y1=+$O(DADRFM("F",(X-.01)))
- .....I $G(DADRFM("S",Y))'=$G(DADRFM("F",Y1)) S X=X+96
- .....Q
- ....S $P(Z,"^",K+(K1-1))=X ;15-minute conversion
- ....I K1=1,N=1!(N=4) S DADRFM("S",-X)=DADRFM
- ....I K1=2,N=1!(N=4) S DADRFM("F",X)=DADRFM,DADRFM=DADRFM+1
- ....I K1=2,X>96,N'=2 S Y=$P(Z,"^",(K+K1)) I Y=""!("12345"'[Y) S X=X-96 D
- .....I "^0^7^14^"'[("^"_+ZZ_"^") Q
- .....I $G(^TMP($J,"PRS8",DAY,"MT1"))>1 S X=X-$G(^TMP($J,"PRS8",DAY,"MT1"))
- .....I ZZ=0!(ZZ=7) S NH($S('ZZ:1,1:2))=NH($S('ZZ:1,1:2))+X
- .....Q:'ZZ ;already moved previous time to this pp
- .....S NH($S(D=7:1,1:2))=NH($S(D=7:1,1:2))-X
- .....Q
- ....Q
- ...I N=4,Z?1AN.E!(Z?1"^".AN) D ;2-tour day
- ....I +D(1)'>+Z S TWO=1_"^"_+Z ;early tour first
- ....E S TWO=2_"^"_+D(1) ;late tour first
- ....Q:+TWO=1 ;we're gonna switch 1&4 nodes if necessary now
- ....S X1=^TMP($J,"PRS8",DAY,1),D1=D,X=1,D(1)=Z D SET ;move 4 node to 1
- ....S Z=X1,N14=1 K X,X1 ;this will move 1 node to 4
- ..S D(N)=Z,D1=D,X=N D SET
- .K DADRFM,MT1,MT2
- .S Z=TWO,D1=D,X="TWO" D SET
- .S Z="",$P(Z,"0",97)="",D1=D,X="W" D SET ;activity string
- .S X="HOL" D SET ;save holiday string
- .S X="P" D SET ;premium node
- .S X="r" D SET ;Recess node
- .S X=D(0),OFF=0 I $P(X,"^",2)=1 S OFF=1 ;day off
- .S Z=OFF,X="OFF" D SET
- .I +TWO=2 S MT2=$G(^TMP($J,"PRS8",D1,"MT2")),MT1=$G(^TMP($J,"PRS8",D1,"MT1")),^TMP($J,"PRS8",D1,"MT2")=MT1,^TMP($J,"PRS8",D1,"MT1")=MT2
- .I TYP["W" D ; -- compute credit tour for WG
- ..S X=D(0) I DAY=0 S (L,T)=0
- ..I $P(X,"^",3) S X=$G(^PRST(457.1,+$P(X,"^",4),1)) ;temp tour
- ..E S X=D(1) ;not temporary
- ..S S=0 F J=1,4 Q:D(J)="" F I=3:3:28 Q:S!($P(D(J),"^",(I-2))="") D
- ...I "^6^7^"[("^"_+$P(D(J),"^",I)_"^") S S=+$P(D(J),"^",I)-4
- ..I 'OFF S:'S S=1 S:(DAY>0)&(DAY<15) L=S ;credit tour
- ..I DAY>0,DAY<15 D
- ...I 'T S T=+S
- ...I S S T=S ;T=credit tour on days off
- ..S Z=S S:TYP'["W"&(Z>1) Z=1 S D1=DAY,X="TOUR" D SET
- ..I DAY=7!(DAY=14) S TOUR((DAY\7))=$S(T:T,1:1),T=0 ;save tour
- I TYP["B" S NH=320,(NH(1),NH(2))=160,TH=192,(TH(1),TH(2))=96 ; Baylor NH=40 hrs to mimic full time, TH = 24 hrs for reality
- E S TH=NH,TH(1)=NH(1),TH(2)=NH(2) ;total hrs for pp
- ;
- ; Update NH for the nurses on the 36/40 AWS
- I "KM"[$E(AC,1),$E(AC,2)=1,NH=288 S NH=320,(NH(1),NH(2))=160,TH=320,(TH(1),TH(2))=160
- ;
- I TYP["W",L>1 S $P(WK(3),"^",3)=L ;last tour (IN) in misc for WG
- S VALOLD=$G(^PRST(458,+PY,"E",+DFN,5)) ;existing decomp
- K D,D1,DAY,NDAY,FLAG,J,K,K1,L,LAST,MT,N,N1,N14,P,QT,T,V,W,X,Y,Y1,Z
- G ^PRS8ST ;start decomp
- ;
- 15 ; --- convert time to 15-minute increments
- ;
- ; Need to conditionally set Y $S(Y=0 mid=00:00, y=1: mid=24:00)
- ; based on whether exception is within or outside the tour.
- D MIL^PRSATIM ;convert to military (24hr) time
- I +Y<1000 S Y=$E("0000",0,4-$L(Y))_Y
- S X=(+$E(Y,1,2)*4)+($E(Y,3,4)\15)
- I 'Y1 S X=X+1 ; Add 15 minutes to start time
- I X<LAST S X=X+96,NDAY=1 ;new day
- S LAST=X Q
- ;
- SET ; --- save value (Z) in ^TMP($J,"PRS8",DAY,X)
- ;
- S D1=+ZZ
- S ^TMP($J,"PRS8",D1,X)=Z Q
- ;
- TAL ; --- T&L Unit (whole zeroth node)
- ;
- S X=$O(^PRST(455.5,"B",X,0))
- S X=$G(^PRST(455.5,+X,0)) I $E(X)="" S X=""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRS8SU 5206 printed Mar 13, 2025@21:28:04 Page 2
- PRS8SU ;HISC/MRL-DECOMPOSITION, SET-UP ;02/20/08
- +1 ;;4.0;PAID;**112,116**;Sep 21, 1995;Build 23
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;This routine sets up various data elements required to process
- +5 ;a decomp. The ^TMP array is built for each day of the
- +6 ;pay period (1-14) and includes tour information, exceptions,
- +7 ;holiday information, etc. All times are converted to 15-minute
- +8 ;increments in this routine (the number of 15-minute increments
- +9 ;into the day). Additionally, the credit tour for WG
- +10 ;employees is determined in this routine.
- +11 ;
- +12 ;Called by Routines: PRS8DR
- +13 ;
- +14 KILL ^TMP($JOB,"PRS8")
- +15 KILL D,DAY
- FOR DAY=0:1:15
- Begin DoDot:1
- +16 IF 'CYA
- IF DAY>1
- IF DAY<15
- IF $EXTRACT($PIECE(PPD,"^",DAY),4,7)="0101"
- SET CYA=DAY
- +17 ;last day of previous pp
- SET P=0
- IF 'DAY
- SET P=+PPD(0)
- SET D=14
- +18 ;first day of next pp
- IF DAY=15
- SET P=+PPD(15)
- SET D=1
- +19 IF P
- SET ZZ=$SELECT(D=14:0,1:15)
- +20 IF 'P
- SET P=+PY
- SET (ZZ,D)=+DAY
- +21 SET W=$SELECT(D<8:1,1:2)
- KILL DADRFM
- SET DADRFM=1
- +22 SET TWO=0
- FOR N=0,1,4,2,10
- SET Z=$GET(^PRST(458,+P,"E",+DFN,"D",+D,N))
- Begin DoDot:2
- +23 SET (N14,NDAY,LAST,QT)=0
- SET D(N)=Z
- SET N1=$SELECT(N=2:4,1:3)
- +24 IF N=0
- IF $SELECT(ZZ<15:1,1:0)
- FOR J=2,13
- IF +$PIECE(D(0),"^",J)
- Begin DoDot:3
- +25 ;normal hours
- SET X=+$PIECE(D(0),"^",$SELECT(J=2:8,1:14))
- if 'X
- QUIT
- +26 ;increment NH
- IF DAY'=0
- SET X=X\.25
- SET NH(W)=NH(W)+X
- +27 ;save NH
- SET Z1=Z
- SET Z=X
- SET D1=D
- SET X="DH"_$SELECT(J=2:1,1:2)
- DO SET
- SET Z=Z1
- +28 SET X=+$PIECE(D(0),"^",J)
- +29 ;mltime
- SET X=+$PIECE($GET(^PRST(457.1,+X,0)),"^",3)
- if 'X
- QUIT
- +30 ;save mltime
- SET X=X\15
- SET MT($SELECT(J=2:1,1:2))=X
- +31 IF X
- SET X1=Z
- SET Z=X
- SET D1=D
- SET X="MT"_$SELECT(J=2:1,1:2)
- DO SET
- SET Z=X1
- End DoDot:3
- +32 IF "^1^2^4^"[("^"_N_"^")
- FOR K=1:N1
- SET V=$PIECE(Z,"^",K,K+1)
- if QT
- QUIT
- Begin DoDot:3
- +33 SET X=$PIECE(Z,U,K,999)
- if X?1"^"."^"!(X="")!(N14=1)
- SET QT=1
- IF QT!($PIECE(Z,U,K)="")
- QUIT
- +34 if K=1
- SET (NDAY,LAST)=0
- FOR K1=1,2
- SET X=$PIECE(V,"^",K1)
- SET (Y,Y1)=K1-1
- IF X'=""
- Begin DoDot:4
- +35 SET FLAG=1
- IF N=2&(K1=1)&("^HW^"[("^"_$PIECE(Z,"^",K+2)_"^"))
- SET FLAG=$SELECT(NDAY=1!(LAST>96)&("^HW^"[("^"_$PIECE(Z,"^",K+2)_"^"))&((X["A")!(X["MID")):0,1:1)
- SET NDAY=0
- +36 if $PIECE(D(0),"^",14)'=""&(X="MID")&(LAST=96)&(N=2)&(K1=1)
- SET FLAG=0
- if N=2&(K1=1)&(FLAG=1)
- SET (NDAY,LAST)=0
- SET Y=K1-1
- DO 15
- +37 IF N=2
- IF "^RG^OT^CT^ON^SB^"'[("^"_$PIECE(Z,"^",K+2)_"^")
- Begin DoDot:5
- +38 SET Y=+$ORDER(DADRFM("S",(-X-.01)))
- SET Y1=+$ORDER(DADRFM("F",(X-.01)))
- +39 IF $GET(DADRFM("S",Y))'=$GET(DADRFM("F",Y1))
- SET X=X+96
- +40 QUIT
- End DoDot:5
- +41 ;15-minute conversion
- SET $PIECE(Z,"^",K+(K1-1))=X
- +42 IF K1=1
- IF N=1!(N=4)
- SET DADRFM("S",-X)=DADRFM
- +43 IF K1=2
- IF N=1!(N=4)
- SET DADRFM("F",X)=DADRFM
- SET DADRFM=DADRFM+1
- +44 IF K1=2
- IF X>96
- IF N'=2
- SET Y=$PIECE(Z,"^",(K+K1))
- IF Y=""!("12345"'[Y)
- SET X=X-96
- Begin DoDot:5
- +45 IF "^0^7^14^"'[("^"_+ZZ_"^")
- QUIT
- +46 IF $GET(^TMP($JOB,"PRS8",DAY,"MT1"))>1
- SET X=X-$GET(^TMP($JOB,"PRS8",DAY,"MT1"))
- +47 IF ZZ=0!(ZZ=7)
- SET NH($SELECT('ZZ:1,1:2))=NH($SELECT('ZZ:1,1:2))+X
- +48 ;already moved previous time to this pp
- if 'ZZ
- QUIT
- +49 SET NH($SELECT(D=7:1,1:2))=NH($SELECT(D=7:1,1:2))-X
- +50 QUIT
- End DoDot:5
- +51 QUIT
- End DoDot:4
- +52 ;2-tour day
- IF N=4
- IF Z?1AN.E!(Z?1"^".AN)
- Begin DoDot:4
- +53 ;early tour first
- IF +D(1)'>+Z
- SET TWO=1_"^"_+Z
- +54 ;late tour first
- IF '$TEST
- SET TWO=2_"^"_+D(1)
- +55 ;we're gonna switch 1&4 nodes if necessary now
- if +TWO=1
- QUIT
- +56 ;move 4 node to 1
- SET X1=^TMP($JOB,"PRS8",DAY,1)
- SET D1=D
- SET X=1
- SET D(1)=Z
- DO SET
- +57 ;this will move 1 node to 4
- SET Z=X1
- SET N14=1
- KILL X,X1
- End DoDot:4
- End DoDot:3
- +58 SET D(N)=Z
- SET D1=D
- SET X=N
- DO SET
- End DoDot:2
- +59 KILL DADRFM,MT1,MT2
- +60 SET Z=TWO
- SET D1=D
- SET X="TWO"
- DO SET
- +61 ;activity string
- SET Z=""
- SET $PIECE(Z,"0",97)=""
- SET D1=D
- SET X="W"
- DO SET
- +62 ;save holiday string
- SET X="HOL"
- DO SET
- +63 ;premium node
- SET X="P"
- DO SET
- +64 ;Recess node
- SET X="r"
- DO SET
- +65 ;day off
- SET X=D(0)
- SET OFF=0
- IF $PIECE(X,"^",2)=1
- SET OFF=1
- +66 SET Z=OFF
- SET X="OFF"
- DO SET
- +67 IF +TWO=2
- SET MT2=$GET(^TMP($JOB,"PRS8",D1,"MT2"))
- SET MT1=$GET(^TMP($JOB,"PRS8",D1,"MT1"))
- SET ^TMP($JOB,"PRS8",D1,"MT2")=MT1
- SET ^TMP($JOB,"PRS8",D1,"MT1")=MT2
- +68 ; -- compute credit tour for WG
- IF TYP["W"
- Begin DoDot:2
- +69 SET X=D(0)
- IF DAY=0
- SET (L,T)=0
- +70 ;temp tour
- IF $PIECE(X,"^",3)
- SET X=$GET(^PRST(457.1,+$PIECE(X,"^",4),1))
- +71 ;not temporary
- IF '$TEST
- SET X=D(1)
- +72 SET S=0
- FOR J=1,4
- if D(J)=""
- QUIT
- FOR I=3:3:28
- if S!($PIECE(D(J),"^",(I-2))="")
- QUIT
- Begin DoDot:3
- +73 IF "^6^7^"[("^"_+$PIECE(D(J),"^",I)_"^")
- SET S=+$PIECE(D(J),"^",I)-4
- End DoDot:3
- +74 ;credit tour
- IF 'OFF
- if 'S
- SET S=1
- if (DAY>0)&(DAY<15)
- SET L=S
- +75 IF DAY>0
- IF DAY<15
- Begin DoDot:3
- +76 IF 'T
- SET T=+S
- +77 ;T=credit tour on days off
- IF S
- SET T=S
- End DoDot:3
- +78 SET Z=S
- if TYP'["W"&(Z>1)
- SET Z=1
- SET D1=DAY
- SET X="TOUR"
- DO SET
- +79 ;save tour
- IF DAY=7!(DAY=14)
- SET TOUR((DAY\7))=$SELECT(T:T,1:1)
- SET T=0
- End DoDot:2
- End DoDot:1
- +80 ; Baylor NH=40 hrs to mimic full time, TH = 24 hrs for reality
- IF TYP["B"
- SET NH=320
- SET (NH(1),NH(2))=160
- SET TH=192
- SET (TH(1),TH(2))=96
- +81 ;total hrs for pp
- IF '$TEST
- SET TH=NH
- SET TH(1)=NH(1)
- SET TH(2)=NH(2)
- +82 ;
- +83 ; Update NH for the nurses on the 36/40 AWS
- +84 IF "KM"[$EXTRACT(AC,1)
- IF $EXTRACT(AC,2)=1
- IF NH=288
- SET NH=320
- SET (NH(1),NH(2))=160
- SET TH=320
- SET (TH(1),TH(2))=160
- +85 ;
- +86 ;last tour (IN) in misc for WG
- IF TYP["W"
- IF L>1
- SET $PIECE(WK(3),"^",3)=L
- +87 ;existing decomp
- SET VALOLD=$GET(^PRST(458,+PY,"E",+DFN,5))
- +88 KILL D,D1,DAY,NDAY,FLAG,J,K,K1,L,LAST,MT,N,N1,N14,P,QT,T,V,W,X,Y,Y1,Z
- +89 ;start decomp
- GOTO ^PRS8ST
- +90 ;
- 15 ; --- convert time to 15-minute increments
- +1 ;
- +2 ; Need to conditionally set Y $S(Y=0 mid=00:00, y=1: mid=24:00)
- +3 ; based on whether exception is within or outside the tour.
- +4 ;convert to military (24hr) time
- DO MIL^PRSATIM
- +5 IF +Y<1000
- SET Y=$EXTRACT("0000",0,4-$LENGTH(Y))_Y
- +6 SET X=(+$EXTRACT(Y,1,2)*4)+($EXTRACT(Y,3,4)\15)
- +7 ; Add 15 minutes to start time
- IF 'Y1
- SET X=X+1
- +8 ;new day
- IF X<LAST
- SET X=X+96
- SET NDAY=1
- +9 SET LAST=X
- QUIT
- +10 ;
- SET ; --- save value (Z) in ^TMP($J,"PRS8",DAY,X)
- +1 ;
- +2 SET D1=+ZZ
- +3 SET ^TMP($JOB,"PRS8",D1,X)=Z
- QUIT
- +4 ;
- TAL ; --- T&L Unit (whole zeroth node)
- +1 ;
- +2 SET X=$ORDER(^PRST(455.5,"B",X,0))
- +3 SET X=$GET(^PRST(455.5,+X,0))
- IF $EXTRACT(X)=""
- SET X=""
