PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;01/17/07
;;4.0;PAID;**2,6,45,69,112,117,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;This routine take the information contained in the WK array
;and creates the activity string to be passed to Austin. The
;WK(1) node contains those items pertaining to Week 1 activity,
;WK(2) contains those items pertaining to Week 2 activity and
;WK(3) contains the Miscellaneous information shown on the bottom
;of the timecard.
;
;Called by Routines: PRS8DR
;
;Variable S contains the lengths of each of the Values for the
;different time codes. Used to format values with leading and
;trailing zero's
N MLINHRS
S MLINHRS=$$MLINHRS^PRSAENT(DFN)
S S="3333333333333333333333333333333334436232333333333333333333"
S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA EB TATCFAFCADNTRSSRSDNDCFCHCPCRTWTSTM"
S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC ED TBTDFBFDAFNHRNSSSHNUCGCICQCSTXTTTN"
S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD"
K V S V="" F I=1,2,3 S V(I)=""
;
;Next section gets Week 1 and Week 2 data and stores in V(WK)
F J=1,2 F I=1:1:38,40,42:1:58 S X=+$P(WK(J),"^",I) I X]"" D
.; Don't report PT/PT for nurses on AWS schedules
.Q:$E(AC,2)=1&($P(C0,U,16)=72)&(I=32) ; 36/40 AWS
.Q:$E(AC,2)=2&($P(C0,U,16)=80)&(I=32) ; 9month AWS
.;
.I TYP'["D",I'=38,I'=40 D QH
.I TYP["D" S X=+X_"0"
.I TYP["Pd",$E(ENT,2)'="D",$P(WK(J),"^",32)="",V(J)="" S V(J)=V(J)_$S(J=1:"PT000",J=2:"PH000",1:"") ;for p/t drs put PT,PH in 8B string even if they are 0 (PT+PH=NH)
.;Part time hours
.I I=32,TYP["P",TYP["N",TYP'["B"!(TYP["H"),'X D Q
..S X=$E("0000000",0,+$E(S,I)-$L(X))_X
..S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X
..Q
.;holiday hours
.I I=37,$P(C0,"^",20)="P",$P(C0,"^",21)="U" D
..S X=$E("0000000",0,+$E(S,I)-$L(X))_X
..I 'X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X
..Q
.S X=+X I I=32,TYP["Pd",X=0 S X=1
.Q:'X
.I I=32,TYP["Pd",X=1 S X=0
.I I=38!(I=40) D
..S Z=X,X=4*$P(WK(J),"^",I+1) D QH
..S X=($E("00",0,$E(S,I)-$L(Z))_+Z)_($E("000",0,$E(S,I+1)-$L(+X))_+X) ;combine env. diff. % and hours
..Q
.E S X=$E("0000000",0,+$E(S,I)-$L(X))_+X
.I +X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X,V=V+X
;Now we get miscellaneous data
;
S S="22134446114423146"
F I=1:1:17 S X=$P(WK(3),"^",I) I X'="" D
.I I=11 D
. . I MLINHRS D QH ; Convert to 1/4 hours.
. . I MLINHRS=0 S X=X_"0" ; Convert to 1/4 hours.
.S X=$E("000000",0,+$E(S,I)-$L(X))_X
.I $D(X) S V(3)=V(3)_$E(E(3),I+(I-1),I*2)_X,V=V+X
;
;finish up
;
S VAL="" I $L(V(1))!($L(V(2)))!($L(V(3))) S X=V(1)_V(2)_V(3)_"CD"_$E("000000",0,6-$L(+V))_+V,VAL=X
;
STUB ; --- enter here to create stub only
I '($D(VAL)#2) S VAL=""
; code below to add CP field to STUB record (32nd position)
S CPFX=""
S CPFX=$P($G(^PRST(458,PY,"E",DFN,0)),"^",6) ;get CP from 458
I CPFX="" S CPFX=$P($G(^PRSPC(DFN,1)),"^",7) ;if 458 null get from 450
I "0"[CPFX S CPFX=" " ;if it is 0 or "" set CPFX = " "
S PPE=$G(^PRST(458,+PY,0)),PPE=$P(PPE,"^",1),PPI=+PY D ^PRSAXSR
S VAL=HDR_CPFX_VAL ;decomp no longer saves 8B in 5 node (6/95)
K I,J,S Q
;
QH ; --- for persons paid hourly/convert to Quarter Hours
;
I I'=37 S X1=X#4,X=X\4_+X1 K X1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRS8CR 3357 printed Sep 23, 2025@19:59:07 Page 2
PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;01/17/07
+1 ;;4.0;PAID;**2,6,45,69,112,117,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;This routine take the information contained in the WK array
+5 ;and creates the activity string to be passed to Austin. The
+6 ;WK(1) node contains those items pertaining to Week 1 activity,
+7 ;WK(2) contains those items pertaining to Week 2 activity and
+8 ;WK(3) contains the Miscellaneous information shown on the bottom
+9 ;of the timecard.
+10 ;
+11 ;Called by Routines: PRS8DR
+12 ;
+13 ;Variable S contains the lengths of each of the Values for the
+14 ;different time codes. Used to format values with leading and
+15 ;trailing zero's
+16 NEW MLINHRS
+17 SET MLINHRS=$$MLINHRS^PRSAENT(DFN)
+18 SET S="3333333333333333333333333333333334436232333333333333333333"
+19 SET E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA EB TATCFAFCADNTRSSRSDNDCFCHCPCRTWTSTM"
+20 SET E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC ED TBTDFBFDAFNHRNSSSHNUCGCICQCSTXTTTN"
+21 SET E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD"
+22 KILL V
SET V=""
FOR I=1,2,3
SET V(I)=""
+23 ;
+24 ;Next section gets Week 1 and Week 2 data and stores in V(WK)
+25 FOR J=1,2
FOR I=1:1:38,40,42:1:58
SET X=+$PIECE(WK(J),"^",I)
IF X]""
Begin DoDot:1
+26 ; Don't report PT/PT for nurses on AWS schedules
+27 ; 36/40 AWS
if $EXTRACT(AC,2)=1&($PIECE(C0,U,16)=72)&(I=32)
QUIT
+28 ; 9month AWS
if $EXTRACT(AC,2)=2&($PIECE(C0,U,16)=80)&(I=32)
QUIT
+29 ;
+30 IF TYP'["D"
IF I'=38
IF I'=40
DO QH
+31 IF TYP["D"
SET X=+X_"0"
+32 ;for p/t drs put PT,PH in 8B string even if they are 0 (PT+PH=NH)
IF TYP["Pd"
IF $EXTRACT(ENT,2)'="D"
IF $PIECE(WK(J),"^",32)=""
IF V(J)=""
SET V(J)=V(J)_$SELECT(J=1:"PT000",J=2:"PH000",1:"")
+33 ;Part time hours
+34 IF I=32
IF TYP["P"
IF TYP["N"
IF TYP'["B"!(TYP["H")
IF 'X
Begin DoDot:2
+35 SET X=$EXTRACT("0000000",0,+$EXTRACT(S,I)-$LENGTH(X))_X
+36 SET V(J)=V(J)_$EXTRACT(E(J),I+(I-1),I*2)_X
+37 QUIT
End DoDot:2
QUIT
+38 ;holiday hours
+39 IF I=37
IF $PIECE(C0,"^",20)="P"
IF $PIECE(C0,"^",21)="U"
Begin DoDot:2
+40 SET X=$EXTRACT("0000000",0,+$EXTRACT(S,I)-$LENGTH(X))_X
+41 IF 'X
SET V(J)=V(J)_$EXTRACT(E(J),I+(I-1),I*2)_X
+42 QUIT
End DoDot:2
+43 SET X=+X
IF I=32
IF TYP["Pd"
IF X=0
SET X=1
+44 if 'X
QUIT
+45 IF I=32
IF TYP["Pd"
IF X=1
SET X=0
+46 IF I=38!(I=40)
Begin DoDot:2
+47 SET Z=X
SET X=4*$PIECE(WK(J),"^",I+1)
DO QH
+48 ;combine env. diff. % and hours
SET X=($EXTRACT("00",0,$EXTRACT(S,I)-$LENGTH(Z))_+Z)_($EXTRACT("000",0,$EXTRACT(S,I+1)-$LENGTH(+X))_+X)
+49 QUIT
End DoDot:2
+50 IF '$TEST
SET X=$EXTRACT("0000000",0,+$EXTRACT(S,I)-$LENGTH(X))_+X
+51 IF +X
SET V(J)=V(J)_$EXTRACT(E(J),I+(I-1),I*2)_X
SET V=V+X
End DoDot:1
+52 ;Now we get miscellaneous data
+53 ;
+54 SET S="22134446114423146"
+55 FOR I=1:1:17
SET X=$PIECE(WK(3),"^",I)
IF X'=""
Begin DoDot:1
+56 IF I=11
Begin DoDot:2
+57 ; Convert to 1/4 hours.
IF MLINHRS
DO QH
+58 ; Convert to 1/4 hours.
IF MLINHRS=0
SET X=X_"0"
End DoDot:2
+59 SET X=$EXTRACT("000000",0,+$EXTRACT(S,I)-$LENGTH(X))_X
+60 IF $DATA(X)
SET V(3)=V(3)_$EXTRACT(E(3),I+(I-1),I*2)_X
SET V=V+X
End DoDot:1
+61 ;
+62 ;finish up
+63 ;
+64 SET VAL=""
IF $LENGTH(V(1))!($LENGTH(V(2)))!($LENGTH(V(3)))
SET X=V(1)_V(2)_V(3)_"CD"_$EXTRACT("000000",0,6-$LENGTH(+V))_+V
SET VAL=X
+65 ;
STUB ; --- enter here to create stub only
+1 IF '($DATA(VAL)#2)
SET VAL=""
+2 ; code below to add CP field to STUB record (32nd position)
+3 SET CPFX=""
+4 ;get CP from 458
SET CPFX=$PIECE($GET(^PRST(458,PY,"E",DFN,0)),"^",6)
+5 ;if 458 null get from 450
IF CPFX=""
SET CPFX=$PIECE($GET(^PRSPC(DFN,1)),"^",7)
+6 ;if it is 0 or "" set CPFX = " "
IF "0"[CPFX
SET CPFX=" "
+7 SET PPE=$GET(^PRST(458,+PY,0))
SET PPE=$PIECE(PPE,"^",1)
SET PPI=+PY
DO ^PRSAXSR
+8 ;decomp no longer saves 8B in 5 node (6/95)
SET VAL=HDR_CPFX_VAL
+9 KILL I,J,S
QUIT
+10 ;
QH ; --- for persons paid hourly/convert to Quarter Hours
+1 ;
+2 IF I'=37
SET X1=X#4
SET X=X\4_+X1
KILL X1
+3 QUIT
