- 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 Feb 18, 2025@23:49:08 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
