Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSDUTIL

PRSDUTIL.m

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