PRSDUTIL ;HISC/MGD-PAID DOWNLOAD UTILITY SUB-ROUTINES ;09/10/2003
;;4.0;PAID;**32,82,99**;Sep 21, 1995
PIC9 ;Replace 0s
S DIF=LTH-$L(GRPVAL) I DIF>0 F FF=1:1:DIF S GRPVAL="0"_GRPVAL
K DIF,FF Q
SIGN ;Sign conversion
S L=$L(DATA),S=$E(DATA,L)
S LC=$S(S="{":0,S="A":1,S="B":2,S="C":3,S="D":4,S="E":5,S="F":6,S="G":7,S="H":8,S="I":9,S="}":0,S="J":1,S="K":2,S="L":3,S="M":4,S="N":5,S="O":6,S="P":7,S="Q":8,S="R":9,1:S)
S DATA=$E(DATA,1,L-1)_LC
S:(S="}")!(S="J")!(S="K")!(S="L")!(S="M")!(S="N")!(S="O")!(S="P")!(S="Q")!(S="R") DATA="-"_DATA
K L,LC,S Q
D ;.0
S L=$L(DATA),DATA=$E(DATA,1,L-1)_"."_$E(DATA,L) K L G RZ
DD ;.00
S L=$L(DATA),DATA=$E(DATA,1,L-2)_"."_$E(DATA,L-1,L) K L G RZ
DDD ;.000
S L=$L(DATA),DATA=$E(DATA,1,L-3)_"."_$E(DATA,L-2,L) K L G RZ
DDDD ;.0000
S L=$L(DATA),DATA=$E(DATA,1,L-4)_"."_$E(DATA,L-3,L) K L G RZ
DDDDD ;.00000
S L=$L(DATA),DATA=$E(DATA,1,L-5)_"."_$E(DATA,L-4,L) K L G RZ
AHRS ;Acct hrs
S L=$L(DATA),LD=$E(DATA,L),FD=$E(DATA,1,L-1)
S LD=$S(LD=0:"00",LD=1:25,LD=2:50,LD=3:75,1:LD)
S DATA=FD_"."_LD,DATA=+DATA
K FD,L,LD G RZ
PCT ;%
S:+$P(DATA,".",2)=0 DATA=DATA\1
S DATA=DATA_"%" Q
RZ ;Remove leading 0s
I +DATA=0 S DATA="" Q
S FC=$E(DATA,1)
S $P(DATA,".")=+$P(DATA,".")
I FC="-",$E(DATA,1)'="-" S DATA="-"_DATA
K FC Q
DATE ;Convert Austin Date to Fileman Date
;Austin's date has form xxYYMMDD or YYYYMMDD
Q:DATA=""
I $E(DATA,5,8)="0000" S DATA="" Q
N X,Y,%DT,DTOUT
S X=$E(DATA,5,8)_$S(+$E(DATA)'=$E(DATA):$E(DATA,3,4),1:$E(DATA,1,4))
S %DT="" D ^%DT
S DATA=$S(Y>0:Y,1:"")
Q
LZ ;Insert leading 0s
F UUU=1:1:L-$L(DATA) S DATA=0_DATA
K L,UUU Q
RTS ;Remove trailing spaces
Q:$E(DATA,$L(DATA))'=" "
F SLOOP=$L(DATA):-1 Q:$E(DATA,SLOOP)'=" " S DATA=$E(DATA,1,SLOOP-1)
K SLOOP Q
OT ;Output trans
Q:Y="" S IEN454=0,IEN454=$O(^PRSP(454,1,SUB454,"B",Y,IEN454))
I IEN454>0,$P(^PRSP(454,1,SUB454,IEN454,0),U,2)'="" S Y=$P(^PRSP(454,1,SUB454,IEN454,0),U,2) I SUB454="ORG",$D(^PRSP(454.1,Y,0)) S Y=$P(^PRSP(454.1,Y,0),U,1)
K IEN454,SUB454 Q
SOT ;State
Q:Y=""
S IEN5=0,IEN5=$O(^DIC(5,"C",Y,IEN5))
S Y=$S(IEN5>0:$P(^DIC(5,IEN5,0),U,1),1:Y)
K IEN5 Q
AC ;Asgmnt code
Q:Y=""
S AC="",AC1="",OSC=$E($P(^PRSPC(D0,0),U,17),1,4)
F LLL=0:0 S LLL=$O(^PRSP(454,1,"ASS","B",Y,LLL)) Q:LLL="" D Q:AC'=""
.S OCCS=$P(^PRSP(454,1,"ASS",LLL,0),U,3)
.I OCCS="" S AC1=$P(^PRSP(454,1,"ASS",LLL,0),"^",2)
.I OCCS[OSC S AC=$P(^PRSP(454,1,"ASS",LLL,0),"^",2)
S Y=$S(AC'="":AC,1:AC1)
K AC,AC1,LLL,OCCS,OSC Q
TITLE ;Title
I DATA=" " S DATA="" Q
S LD=$E(DATA,6) S:LD'?1N $P(^PRSPC(IEN,0),U,42)=LD
I $P(^PRSPC(IEN,0),U,42)?1U&(LD?1N) S $P(^PRSPC(IEN,0),U,42)=""
K LD Q
NH ;Norm Hrs
S DATA=+DATA,DB=$P(^PRSPC(IEN,0),U,10)
S NH=$S(DATA>0:DATA,DB=1:80,DB=2:DATA,DB=3:0,1:0)
S $P(^PRSPC(IEN,0),U,50)=NH
K DB,NH Q
STEP ;Step
I DATA=" " S DATA="" Q
S:$E(DATA,1)=" " DATA=$E(DATA,2) Q
ORGCC ;Org/Cost Cntr
I DBNAME="MXORGCOD" S COST=$E(DATA,1,4),$P(^PRSPC(IEN,0),U,18)=COST
S CCORG=$E(DATA,1,4)_":"_$E(DATA,5,8)
I '$D(^PRSP(454,1,"ORG","B",CCORG)) K DD,DO S DIC="^PRSP(454,1,""ORG"",",DIC(0)="L",DLAYGO=454,X=CCORG D FILE^DICN S ^TMP($J,"ORG",CCORG)=""
K COST,CCORG,DIC,DLAYGO,X Q
PVAE ;Prior VA Exp
F ABC=1:1:$L(DATA) S PV=$E(DATA,ABC),PIECE=$S(PV="A":1,PV="B":2,PV="C":3,PV="D":4,PV="E":5,PV="F":6,PV="G":7,PV="H":8,PV="I":9,PV="J":10,PV="K":11,PV="L":12,PV="M":13,PV=0:ABC,1:"") S:PIECE'="" $P(^PRSPC(IEN,NODE),U,PIECE)=PV
K ABC,PV Q
ZIP ;Zip
I +DATA=0 S DATA="" Q
I $E(DATA,6,9)="0000" S DATA=$E(DATA,1,5) Q
S DATA=$E(DATA,1,5)_"-"_$E(DATA,6,9) Q
NPLWOP ;Nonpay & LWOP Hrs
S LVGRP=$P(^PRSPC(IEN,0),U,15)
S NPLWOP=$S((LVGRP=4)!(LVGRP=5):$J((DATA/14)*80,1,0),1:DATA)
I DBNAME="ANONPATIME" S $P(^PRSPC(IEN,1),U,43)=NPLWOP S:TYPE="P" $P(^PRST(459,PPIEN,"P",IEN,6),U,5)=NPLWOP
I DBNAME="ALWOPUSED" S $P(^PRSPC(IEN,"LWOP"),U,11)=NPLWOP S:TYPE="P" $P(^PRST(459,PPIEN,"P",IEN,4),U,9)=NPLWOP
K LVGRP,NPLWOP Q
NEWSSN ;New SSN
I $L(DATA)<9 S L=9 D LZ
Q
COMP ;0 out comp time bal
I DATA="",$E(^PRSPC(IEN,"COMP"),1,7)="^^^^^^^",$P(^PRSPC(IEN,"COMP"),U,9)'="" F ABC=9:1:17 S $P(^PRSPC(IEN,"COMP"),U,ABC)=""
Q
OST ;Occupation Series & Title Output Transform
S OSC=Y,OSC14=$E(Y,1,4),OSC15=$E(Y,1,5),LD=$E(Y,6)
G:LD?1N OSTOT
I OSC14<2200 S NLD=$S((LD="A")!(LD="J"):1,(LD="B")!(LD="K"):2,(LD="C")!(LD="L"):3,(LD="D")!(LD="M"):4,(LD="E")!(LD="N"):5,(LD="F")!(LD="O"):6,(LD="G")!(LD="P"):7,(LD="H")!(LD="Q"):8,(LD="I")!(LD="R"):9,1:LD) S Y=OSC15_NLD
I OSC14>2600,LD'?1N S Y=OSC15_"0"
OSTOT S SUB454="OCC" D OT^PRSDUTIL K SUB454
I OSC14<2200,(LD="A")!(LD="B")!(LD="C")!(LD="D")!(LD="E")!(LD="F")!(LD="G")!(LD="H")!(LD="I") S:(Y'["OFFICER")!(Y="POLICE OFFICER") Y="SUPERVISORY "_Y G OSTEX
I OSC14<2200,(LD="J")!(LD="K")!(LD="L")!(LD="M")!(LD="N")!(LD="O")!(LD="P")!(LD="Q")!(LD="R") S Y="LEAD "_Y G OSTEX
I OSC14>2600,(LD="F")!(LD="G")!(LD="H")!(LD="L")!(LD="S") S SUF=$S(LD="H":" HELPER",LD="L":" LEADER",LD="F":" FOREMAN",LD="G":" GENERAL FOREMAN",LD="S":" SUPERVISOR",1:LD),Y=Y_SUF
OSTEX K OSC,OSC14,OSC15,LD,NLD,SUF
Q
;
LD ; Set Labor Distribution fields into Multiple.
N PRSTMP
S PRSTMP=DATA,DATA=$E(DATA,1,4)
D LD^PRSDSET
S DATA=PRSTMP
Q
;==============================================================
PATCH32 ;Subprograms LOOP450 and DTCMP are post-installation routines
;for patch PRS*4*32. They have no other intended use.
;Convert fields that have received year 2000 dates from Austin.
;Loop thru all employee records. Within employee records loop thru
;the 9 nodes (see ND variable) in each record that contain potential
;problem dates. Traverse the up arrow delimited data in each node,
;but only check the pieces defined in the CHECK array nodes.
;Convert dates in those fields that fall between jan 01, 1900 and
;DEC 31, 1910 inclusively. The conversion will only change the
;century to the 21st.
;
;
Q
;==============================================================
LOOP450 ;
;
;****Keep post-installation from running on subsequent patch installs
I $$PATCH^XPDUTL("PRS*4.0*32") D MSSG(0) Q
;
D MSSG(1)
N CHECK,ND,REC,PIECES,XPDIDTOT,DIV,%
S CHECK(0)="51^"
S CHECK(1)="30^"
S CHECK(2)="2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^20^22^23^24^25^26^27^28^29^30^31^32^"
S CHECK(3)="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^19^20^21^22^"
S CHECK(4)="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^19^20^"
S CHECK("PCD")="4^"
S CHECK("MSD2")="9^"
S CHECK("BOND1")="12^"
S CHECK("BOND2")="11^"
S CHECK("TSP1")="5^12^14^"
;
S XPDIDTOT=$P($G(^PRSPC(0)),"^",4)
S DIV=XPDIDTOT\20
S %=0
S REC=0 F S REC=$O(^PRSPC(REC)) Q:REC'>0 D
. S %=%+1
. I '(%#DIV) D UPDATE^XPDID(%)
. S ND=""
. F S ND=$O(CHECK(ND)) Q:ND="" D
.. I $G(^PRSPC(REC,ND))'="" D
... S PIECES=CHECK(ND)
... D DTCMP(REC,ND,$G(^PRSPC(REC,ND)),PIECES)
Q
;==============================================================
DTCMP(IEN,NODE,DATANODE,PIECES) ;
;Look at all PEICES in a single DATANODE of an employee's record
;and convert dates from 1900-1910 to respective dates in 2000-2010.
N PIECE,NEXT,NEWDATE,DATA
F NEXT=1:1 S PIECE=$P(PIECES,"^",NEXT) Q:PIECE="" D
. S DATA=$P(DATANODE,"^",PIECE)
. I (DATA<2110101),(DATA>1991231) D
.. S NEWDATE="3"_$E(DATA,2,7)
.. S $P(^PRSPC(IEN,NODE),"^",PIECE)=NEWDATE
Q
;==============================================================
MSSG(FLAG) ;OUT PUT POST INSTALLATION MESSAGE.
N MSSG
I FLAG S MSSG="Checking date fields in File 450."
E S MSSG="Date fields not checked. Checked during previous install of PRS*4*32"
D MES^XPDUTL(MSSG)
Q
;==============================================================
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDUTIL 7740 printed Nov 22, 2024@17:36:13 Page 2
PRSDUTIL ;HISC/MGD-PAID DOWNLOAD UTILITY SUB-ROUTINES ;09/10/2003
+1 ;;4.0;PAID;**32,82,99**;Sep 21, 1995
PIC9 ;Replace 0s
+1 SET DIF=LTH-$LENGTH(GRPVAL)
IF DIF>0
FOR FF=1:1:DIF
SET GRPVAL="0"_GRPVAL
+2 KILL DIF,FF
QUIT
SIGN ;Sign conversion
+1 SET L=$LENGTH(DATA)
SET S=$EXTRACT(DATA,L)
+2 SET LC=$SELECT(S="{":0,S="A":1,S="B":2,S="C":3,S="D":4,S="E":5,S="F":6,S="G":7,S="H":8,S="I":9,S="}":0,S="J":1,S="K":2,S="L":3,S="M":4,S="N":5,S="O":6,S="P":7,S="Q":8,S="R":9,1:S)
+3 SET DATA=$EXTRACT(DATA,1,L-1)_LC
+4 if (S="}")!(S="J")!(S="K")!(S="L")!(S="M")!(S="N")!(S="O")!(S="P")!(S="Q")!(S="R")
SET DATA="-"_DATA
+5 KILL L,LC,S
QUIT
D ;.0
+1 SET L=$LENGTH(DATA)
SET DATA=$EXTRACT(DATA,1,L-1)_"."_$EXTRACT(DATA,L)
KILL L
GOTO RZ
DD ;.00
+1 SET L=$LENGTH(DATA)
SET DATA=$EXTRACT(DATA,1,L-2)_"."_$EXTRACT(DATA,L-1,L)
KILL L
GOTO RZ
DDD ;.000
+1 SET L=$LENGTH(DATA)
SET DATA=$EXTRACT(DATA,1,L-3)_"."_$EXTRACT(DATA,L-2,L)
KILL L
GOTO RZ
DDDD ;.0000
+1 SET L=$LENGTH(DATA)
SET DATA=$EXTRACT(DATA,1,L-4)_"."_$EXTRACT(DATA,L-3,L)
KILL L
GOTO RZ
DDDDD ;.00000
+1 SET L=$LENGTH(DATA)
SET DATA=$EXTRACT(DATA,1,L-5)_"."_$EXTRACT(DATA,L-4,L)
KILL L
GOTO RZ
AHRS ;Acct hrs
+1 SET L=$LENGTH(DATA)
SET LD=$EXTRACT(DATA,L)
SET FD=$EXTRACT(DATA,1,L-1)
+2 SET LD=$SELECT(LD=0:"00",LD=1:25,LD=2:50,LD=3:75,1:LD)
+3 SET DATA=FD_"."_LD
SET DATA=+DATA
+4 KILL FD,L,LD
GOTO RZ
PCT ;%
+1 if +$PIECE(DATA,".",2)=0
SET DATA=DATA\1
+2 SET DATA=DATA_"%"
QUIT
RZ ;Remove leading 0s
+1 IF +DATA=0
SET DATA=""
QUIT
+2 SET FC=$EXTRACT(DATA,1)
+3 SET $PIECE(DATA,".")=+$PIECE(DATA,".")
+4 IF FC="-"
IF $EXTRACT(DATA,1)'="-"
SET DATA="-"_DATA
+5 KILL FC
QUIT
DATE ;Convert Austin Date to Fileman Date
+1 ;Austin's date has form xxYYMMDD or YYYYMMDD
+2 if DATA=""
QUIT
+3 IF $EXTRACT(DATA,5,8)="0000"
SET DATA=""
QUIT
+4 NEW X,Y,%DT,DTOUT
+5 SET X=$EXTRACT(DATA,5,8)_$SELECT(+$EXTRACT(DATA)'=$EXTRACT(DATA):$EXTRACT(DATA,3,4),1:$EXTRACT(DATA,1,4))
+6 SET %DT=""
DO ^%DT
+7 SET DATA=$SELECT(Y>0:Y,1:"")
+8 QUIT
LZ ;Insert leading 0s
+1 FOR UUU=1:1:L-$LENGTH(DATA)
SET DATA=0_DATA
+2 KILL L,UUU
QUIT
RTS ;Remove trailing spaces
+1 if $EXTRACT(DATA,$LENGTH(DATA))'=" "
QUIT
+2 FOR SLOOP=$LENGTH(DATA):-1
if $EXTRACT(DATA,SLOOP)'=" "
QUIT
SET DATA=$EXTRACT(DATA,1,SLOOP-1)
+3 KILL SLOOP
QUIT
OT ;Output trans
+1 if Y=""
QUIT
SET IEN454=0
SET IEN454=$ORDER(^PRSP(454,1,SUB454,"B",Y,IEN454))
+2 IF IEN454>0
IF $PIECE(^PRSP(454,1,SUB454,IEN454,0),U,2)'=""
SET Y=$PIECE(^PRSP(454,1,SUB454,IEN454,0),U,2)
IF SUB454="ORG"
IF $DATA(^PRSP(454.1,Y,0))
SET Y=$PIECE(^PRSP(454.1,Y,0),U,1)
+3 KILL IEN454,SUB454
QUIT
SOT ;State
+1 if Y=""
QUIT
+2 SET IEN5=0
SET IEN5=$ORDER(^DIC(5,"C",Y,IEN5))
+3 SET Y=$SELECT(IEN5>0:$PIECE(^DIC(5,IEN5,0),U,1),1:Y)
+4 KILL IEN5
QUIT
AC ;Asgmnt code
+1 if Y=""
QUIT
+2 SET AC=""
SET AC1=""
SET OSC=$EXTRACT($PIECE(^PRSPC(D0,0),U,17),1,4)
+3 FOR LLL=0:0
SET LLL=$ORDER(^PRSP(454,1,"ASS","B",Y,LLL))
if LLL=""
QUIT
Begin DoDot:1
+4 SET OCCS=$PIECE(^PRSP(454,1,"ASS",LLL,0),U,3)
+5 IF OCCS=""
SET AC1=$PIECE(^PRSP(454,1,"ASS",LLL,0),"^",2)
+6 IF OCCS[OSC
SET AC=$PIECE(^PRSP(454,1,"ASS",LLL,0),"^",2)
End DoDot:1
if AC'=""
QUIT
+7 SET Y=$SELECT(AC'="":AC,1:AC1)
+8 KILL AC,AC1,LLL,OCCS,OSC
QUIT
TITLE ;Title
+1 IF DATA=" "
SET DATA=""
QUIT
+2 SET LD=$EXTRACT(DATA,6)
if LD'?1N
SET $PIECE(^PRSPC(IEN,0),U,42)=LD
+3 IF $PIECE(^PRSPC(IEN,0),U,42)?1U&(LD?1N)
SET $PIECE(^PRSPC(IEN,0),U,42)=""
+4 KILL LD
QUIT
NH ;Norm Hrs
+1 SET DATA=+DATA
SET DB=$PIECE(^PRSPC(IEN,0),U,10)
+2 SET NH=$SELECT(DATA>0:DATA,DB=1:80,DB=2:DATA,DB=3:0,1:0)
+3 SET $PIECE(^PRSPC(IEN,0),U,50)=NH
+4 KILL DB,NH
QUIT
STEP ;Step
+1 IF DATA=" "
SET DATA=""
QUIT
+2 if $EXTRACT(DATA,1)=" "
SET DATA=$EXTRACT(DATA,2)
QUIT
ORGCC ;Org/Cost Cntr
+1 IF DBNAME="MXORGCOD"
SET COST=$EXTRACT(DATA,1,4)
SET $PIECE(^PRSPC(IEN,0),U,18)=COST
+2 SET CCORG=$EXTRACT(DATA,1,4)_":"_$EXTRACT(DATA,5,8)
+3 IF '$DATA(^PRSP(454,1,"ORG","B",CCORG))
KILL DD,DO
SET DIC="^PRSP(454,1,""ORG"","
SET DIC(0)="L"
SET DLAYGO=454
SET X=CCORG
DO FILE^DICN
SET ^TMP($JOB,"ORG",CCORG)=""
+4 KILL COST,CCORG,DIC,DLAYGO,X
QUIT
PVAE ;Prior VA Exp
+1 FOR ABC=1:1:$LENGTH(DATA)
SET PV=$EXTRACT(DATA,ABC)
SET PIECE=$SELECT(PV="A":1,PV="B":2,PV="C":3,PV="D":4,PV="E":5,PV="F":6,PV="G":7,PV="H":8,PV="I":9,PV="J":10,PV="K":11,PV="L":12,PV="M":13,PV=0:ABC,1:"")
if PIECE'=""
SET $PIECE(^PRSPC(IEN,NODE),U,PIECE)=PV
+2 KILL ABC,PV
QUIT
ZIP ;Zip
+1 IF +DATA=0
SET DATA=""
QUIT
+2 IF $EXTRACT(DATA,6,9)="0000"
SET DATA=$EXTRACT(DATA,1,5)
QUIT
+3 SET DATA=$EXTRACT(DATA,1,5)_"-"_$EXTRACT(DATA,6,9)
QUIT
NPLWOP ;Nonpay & LWOP Hrs
+1 SET LVGRP=$PIECE(^PRSPC(IEN,0),U,15)
+2 SET NPLWOP=$SELECT((LVGRP=4)!(LVGRP=5):$JUSTIFY((DATA/14)*80,1,0),1:DATA)
+3 IF DBNAME="ANONPATIME"
SET $PIECE(^PRSPC(IEN,1),U,43)=NPLWOP
if TYPE="P"
SET $PIECE(^PRST(459,PPIEN,"P",IEN,6),U,5)=NPLWOP
+4 IF DBNAME="ALWOPUSED"
SET $PIECE(^PRSPC(IEN,"LWOP"),U,11)=NPLWOP
if TYPE="P"
SET $PIECE(^PRST(459,PPIEN,"P",IEN,4),U,9)=NPLWOP
+5 KILL LVGRP,NPLWOP
QUIT
NEWSSN ;New SSN
+1 IF $LENGTH(DATA)<9
SET L=9
DO LZ
+2 QUIT
COMP ;0 out comp time bal
+1 IF DATA=""
IF $EXTRACT(^PRSPC(IEN,"COMP"),1,7)="^^^^^^^"
IF $PIECE(^PRSPC(IEN,"COMP"),U,9)'=""
FOR ABC=9:1:17
SET $PIECE(^PRSPC(IEN,"COMP"),U,ABC)=""
+2 QUIT
OST ;Occupation Series & Title Output Transform
+1 SET OSC=Y
SET OSC14=$EXTRACT(Y,1,4)
SET OSC15=$EXTRACT(Y,1,5)
SET LD=$EXTRACT(Y,6)
+2 if LD?1N
GOTO OSTOT
+3 IF OSC14<2200
SET NLD=$SELECT((LD="A")!(LD="J"):1,(LD="B")!(LD="K"):2,(LD="C")!(LD="L"):3,(LD="D")!(LD="M"):4,(LD="E")!(LD="N"):5,(LD="F")!(LD="O"):6,(LD="G")!(LD="P"):7,(LD="H")!(LD="Q"):8,(LD="I")!(LD="R"):9,1:LD)
SET Y=OSC15_NLD
+4 IF OSC14>2600
IF LD'?1N
SET Y=OSC15_"0"
OSTOT SET SUB454="OCC"
DO OT^PRSDUTIL
KILL SUB454
+1 IF OSC14<2200
IF (LD="A")!(LD="B")!(LD="C")!(LD="D")!(LD="E")!(LD="F")!(LD="G")!(LD="H")!(LD="I")
if (Y'["OFFICER")!(Y="POLICE OFFICER")
SET Y="SUPERVISORY "_Y
GOTO OSTEX
+2 IF OSC14<2200
IF (LD="J")!(LD="K")!(LD="L")!(LD="M")!(LD="N")!(LD="O")!(LD="P")!(LD="Q")!(LD="R")
SET Y="LEAD "_Y
GOTO OSTEX
+3 IF OSC14>2600
IF (LD="F")!(LD="G")!(LD="H")!(LD="L")!(LD="S")
SET SUF=$SELECT(LD="H":" HELPER",LD="L":" LEADER",LD="F":" FOREMAN",LD="G":" GENERAL FOREMAN",LD="S":" SUPERVISOR",1:LD)
SET Y=Y_SUF
OSTEX KILL OSC,OSC14,OSC15,LD,NLD,SUF
+1 QUIT
+2 ;
LD ; Set Labor Distribution fields into Multiple.
+1 NEW PRSTMP
+2 SET PRSTMP=DATA
SET DATA=$EXTRACT(DATA,1,4)
+3 DO LD^PRSDSET
+4 SET DATA=PRSTMP
+5 QUIT
+6 ;==============================================================
PATCH32 ;Subprograms LOOP450 and DTCMP are post-installation routines
+1 ;for patch PRS*4*32. They have no other intended use.
+2 ;Convert fields that have received year 2000 dates from Austin.
+3 ;Loop thru all employee records. Within employee records loop thru
+4 ;the 9 nodes (see ND variable) in each record that contain potential
+5 ;problem dates. Traverse the up arrow delimited data in each node,
+6 ;but only check the pieces defined in the CHECK array nodes.
+7 ;Convert dates in those fields that fall between jan 01, 1900 and
+8 ;DEC 31, 1910 inclusively. The conversion will only change the
+9 ;century to the 21st.
+10 ;
+11 ;
+12 QUIT
+13 ;==============================================================
LOOP450 ;
+1 ;
+2 ;****Keep post-installation from running on subsequent patch installs
+3 IF $$PATCH^XPDUTL("PRS*4.0*32")
DO MSSG(0)
QUIT
+4 ;
+5 DO MSSG(1)
+6 NEW CHECK,ND,REC,PIECES,XPDIDTOT,DIV,%
+7 SET CHECK(0)="51^"
+8 SET CHECK(1)="30^"
+9 SET CHECK(2)="2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^20^22^23^24^25^26^27^28^29^30^31^32^"
+10 SET CHECK(3)="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^19^20^21^22^"
+11 SET CHECK(4)="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^19^20^"
+12 SET CHECK("PCD")="4^"
+13 SET CHECK("MSD2")="9^"
+14 SET CHECK("BOND1")="12^"
+15 SET CHECK("BOND2")="11^"
+16 SET CHECK("TSP1")="5^12^14^"
+17 ;
+18 SET XPDIDTOT=$PIECE($GET(^PRSPC(0)),"^",4)
+19 SET DIV=XPDIDTOT\20
+20 SET %=0
+21 SET REC=0
FOR
SET REC=$ORDER(^PRSPC(REC))
if REC'>0
QUIT
Begin DoDot:1
+22 SET %=%+1
+23 IF '(%#DIV)
DO UPDATE^XPDID(%)
+24 SET ND=""
+25 FOR
SET ND=$ORDER(CHECK(ND))
if ND=""
QUIT
Begin DoDot:2
+26 IF $GET(^PRSPC(REC,ND))'=""
Begin DoDot:3
+27 SET PIECES=CHECK(ND)
+28 DO DTCMP(REC,ND,$GET(^PRSPC(REC,ND)),PIECES)
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;==============================================================
DTCMP(IEN,NODE,DATANODE,PIECES) ;
+1 ;Look at all PEICES in a single DATANODE of an employee's record
+2 ;and convert dates from 1900-1910 to respective dates in 2000-2010.
+3 NEW PIECE,NEXT,NEWDATE,DATA
+4 FOR NEXT=1:1
SET PIECE=$PIECE(PIECES,"^",NEXT)
if PIECE=""
QUIT
Begin DoDot:1
+5 SET DATA=$PIECE(DATANODE,"^",PIECE)
+6 IF (DATA<2110101)
IF (DATA>1991231)
Begin DoDot:2
+7 SET NEWDATE="3"_$EXTRACT(DATA,2,7)
+8 SET $PIECE(^PRSPC(IEN,NODE),"^",PIECE)=NEWDATE
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;==============================================================
MSSG(FLAG) ;OUT PUT POST INSTALLATION MESSAGE.
+1 NEW MSSG
+2 IF FLAG
SET MSSG="Checking date fields in File 450."
+3 IF '$TEST
SET MSSG="Date fields not checked. Checked during previous install of PRS*4*32"
+4 DO MES^XPDUTL(MSSG)
+5 QUIT
+6 ;==============================================================
