PRSDPROC ;SC/GWB-PAID DOWNLOAD PRS GLOBAL PROCESSOR ;5/6/93 13:12
;;4.0;PAID;**109**;Sep 21, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
I '$D(^XTMP("PRS","TMP")) W !!,"There is no unprocessed PAID download data." R !!,"Press return to continue ",A:DTIME K A Q
TASK S ANS=""
S %=0 W !!,"Do you want to task this job" D YN^DICN
I %=-1 G EXIT
I %=0 W !,?4,*7,"ANSWER 'YES' OR 'NO':" G TASK
I %=1 S ZTRTN="PROC^PRSDPROC",ZTIO="",ZTDESC="PAID DOWNLOAD PROCESSOR" D ^%ZTLOAD Q
S:%=2 ANS="N"
PROC S DATE="",SUB="TMP" D NOW^%DTC S TIME=%
F L1=1:1 S DATE=$O(^XTMP("PRS",SUB,DATE)) Q:DATE="" S TYPE="" F L2=1:1 S TYPE=$O(^XTMP("PRS",SUB,DATE,TYPE)) Q:TYPE="" S STA="" F L3=1:1 S STA=$O(^XTMP("PRS",SUB,DATE,TYPE,STA)) Q:STA="" S ECNT=0 D MSG,START^PRSDSERV,^PRSDSTAT
EXIT D EXIT^PRSDSERV
I $D(ZTQUEUED) S ZTREQ="@"
K ANS,L1,L2,L3,TIME
Q
ERR I '$D(^XTMP("PRS","ERR")) W !!,"There are no unprocessed PAID download errors." R !!,"Press return to continue ",A:DTIME K A Q
S DATE="",SUB="ERR"
F L1=1:1 S DATE=$O(^XTMP("PRS",SUB,DATE)) Q:DATE="" S TYPE="" F L2=1:1 S TYPE=$O(^XTMP("PRS",SUB,DATE,TYPE)) Q:TYPE="" S STA="" F L3=1:1 S STA=$O(^XTMP("PRS",SUB,DATE,TYPE,STA)) Q:STA="" S ECNT=0,ANS="" D MSG,START^PRSDSERV
G EXIT
MSG S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
Q:'$D(ANS)
W !!,"Processing ",MTYPE," data for station ",STA," for ",$E(DATE,5,6),"/",$E(DATE,7,8),"/",$E(DATE,3,4)," "
Q
PRSD ;R !,"SSN: ",SSN:DTIME G:(SSN["^")!(SSN="") PRSDEX
;R !,"START WITH MSG #: ",MSGNUM:DTIME G:(MSGNUM["^")!(MSGNUM="") PRSDEX
;S BSKTIEN=0,BSKTIEN=$O(^XMB(3.7,.5,2,"B","S.PRSD",BSKTIEN))
;S XMZ=MSGNUM-1 F S XMZ=$O(^XMB(3.7,.5,2,BSKTIEN,1,XMZ)) Q:XMZ'>0 W "." S XMPOS=0 F D REC^XMS3 Q:XMER<0 D
;.I XMRG["****PDH" S TYPE=XMRG
;.I XMRG[SSN W !!,XMZ_"-"_XMPOS_TYPE,!!,XMRG
PRSDEX ;K SSN,MSGNUM,BSKTIEN,XMZ,TYPE,XMRG,XMER,XMPOS
;Q
XMB R !,"APPLICATION: ",APP:DTIME G:(APP["^")!(APP="") XMBEX
R !,"ROUTING IND: ",RI:DTIME G:(RI["^")!(RI="") XMBEX
R !,"DAY NUMBER: ",DN:DTIME G:(DN["^")!(DN="") XMBEX
R !,"SSN: ",SSN:DTIME G:(SSN["^")!(SSN="") XMBEX
S SUB=APP_"/"_RI_" #"_DN,TYPE=""
F S SUB=$O(^XMB(3.9,"B",SUB)) Q:SUB'[APP W "." S XMZ=0,XMZ=$O(^XMB(3.9,"B",SUB,XMZ)) S XMPOS=0 F D REC^XMS3 Q:XMER<0 D
.I XMRG["****PDH" S TYPE=XMRG
.I XMRG[SSN W !!,XMZ_"-"_XMPOS_TYPE,!!,XMRG
XMBEX K APP,RI,DN,SSN,SUB,TYPE,XMZ,XMRG,XMER,XMPOS
Q
FIX R !,"IEN#1: ",IEN1:DTIME G:(IEN1["^")!(IEN1="") FIXEX
R !,"IEN#2: ",IEN2:DTIME G:(IEN2["^")!(IEN2="") FIXEX
S PPIEN=0 F S PPIEN=$O(^PRST(459,PPIEN)) Q:PPIEN'>0 I $D(^PRST(459,PPIEN,"P",IEN1)) D
.W !,"PAY PERIOD ",^PRST(459,PPIEN,0)
.S %X="^PRST(459,PPIEN,""P"","_IEN1_","
.S %Y="^PRST(459,PPIEN,""P"","_IEN2_","
.I '$D(^PRST(459,PPIEN,"P",IEN2)) D %XY^%RCR S $P(^PRST(459,PPIEN,"P",IEN2,0),"^",1)=IEN2,^PRST(459,PPIEN,"P","B",IEN2,IEN2)=""
.K ^PRST(459,PPIEN,"P",IEN1),^PRST(459,PPIEN,"P","B",IEN1,IEN1)
S PPIEN=0 F S PPIEN=$O(^PRST(455,PPIEN)) Q:PPIEN'>0 I $D(^PRST(455,PPIEN,1,IEN1)) D
.W !,"PAY PERIOD ",$P(^PRST(455,PPIEN,0),"^",1)
.S %X="^PRST(455,PPIEN,1,"_IEN1_","
.S %Y="^PRST(455,PPIEN,1,"_IEN2_","
.I '$D(^PRST(455,PPIEN,1,IEN2)) D %XY^%RCR S $P(^PRST(455,PPIEN,1,IEN2,0),"^",1)=IEN2,^PRST(455,PPIEN,1,"B",IEN2,IEN2)=""
.K ^PRST(455,PPIEN,1,IEN1),^PRST(455,PPIEN,1,"B",IEN1,IEN1)
D FIXEX G FIX
FIXEX K IEN1,IEN2,PPIEN,%X,%Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDPROC 3461 printed Apr 09, 2024@21:31:47 Page 2
PRSDPROC ;SC/GWB-PAID DOWNLOAD PRS GLOBAL PROCESSOR ;5/6/93 13:12
+1 ;;4.0;PAID;**109**;Sep 21, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 IF '$DATA(^XTMP("PRS","TMP"))
WRITE !!,"There is no unprocessed PAID download data."
READ !!,"Press return to continue ",A:DTIME
KILL A
QUIT
TASK SET ANS=""
+1 SET %=0
WRITE !!,"Do you want to task this job"
DO YN^DICN
+2 IF %=-1
GOTO EXIT
+3 IF %=0
WRITE !,?4,*7,"ANSWER 'YES' OR 'NO':"
GOTO TASK
+4 IF %=1
SET ZTRTN="PROC^PRSDPROC"
SET ZTIO=""
SET ZTDESC="PAID DOWNLOAD PROCESSOR"
DO ^%ZTLOAD
QUIT
+5 if %=2
SET ANS="N"
PROC SET DATE=""
SET SUB="TMP"
DO NOW^%DTC
SET TIME=%
+1 FOR L1=1:1
SET DATE=$ORDER(^XTMP("PRS",SUB,DATE))
if DATE=""
QUIT
SET TYPE=""
FOR L2=1:1
SET TYPE=$ORDER(^XTMP("PRS",SUB,DATE,TYPE))
if TYPE=""
QUIT
SET STA=""
FOR L3=1:1
SET STA=$ORDER(^XTMP("PRS",SUB,DATE,TYPE,STA))
if STA=""
QUIT
SET ECNT=0
DO MSG
DO START^PRSDSERV
DO ^PRSDSTAT
EXIT DO EXIT^PRSDSERV
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ANS,L1,L2,L3,TIME
+3 QUIT
ERR IF '$DATA(^XTMP("PRS","ERR"))
WRITE !!,"There are no unprocessed PAID download errors."
READ !!,"Press return to continue ",A:DTIME
KILL A
QUIT
+1 SET DATE=""
SET SUB="ERR"
+2 FOR L1=1:1
SET DATE=$ORDER(^XTMP("PRS",SUB,DATE))
if DATE=""
QUIT
SET TYPE=""
FOR L2=1:1
SET TYPE=$ORDER(^XTMP("PRS",SUB,DATE,TYPE))
if TYPE=""
QUIT
SET STA=""
FOR L3=1:1
SET STA=$ORDER(^XTMP("PRS",SUB,DATE,TYPE,STA))
if STA=""
QUIT
SET ECNT=0
SET ANS=""
DO MSG
DO START^PRSDSERV
+3 GOTO EXIT
MSG SET MTYPE=$SELECT(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
+1 if '$DATA(ANS)
QUIT
+2 WRITE !!,"Processing ",MTYPE," data for station ",STA," for ",$EXTRACT(DATE,5,6),"/",$EXTRACT(DATE,7,8),"/",$EXTRACT(DATE,3,4)," "
+3 QUIT
PRSD ;R !,"SSN: ",SSN:DTIME G:(SSN["^")!(SSN="") PRSDEX
+1 ;R !,"START WITH MSG #: ",MSGNUM:DTIME G:(MSGNUM["^")!(MSGNUM="") PRSDEX
+2 ;S BSKTIEN=0,BSKTIEN=$O(^XMB(3.7,.5,2,"B","S.PRSD",BSKTIEN))
+3 ;S XMZ=MSGNUM-1 F S XMZ=$O(^XMB(3.7,.5,2,BSKTIEN,1,XMZ)) Q:XMZ'>0 W "." S XMPOS=0 F D REC^XMS3 Q:XMER<0 D
+4 ;.I XMRG["****PDH" S TYPE=XMRG
+5 ;.I XMRG[SSN W !!,XMZ_"-"_XMPOS_TYPE,!!,XMRG
PRSDEX ;K SSN,MSGNUM,BSKTIEN,XMZ,TYPE,XMRG,XMER,XMPOS
+1 ;Q
XMB READ !,"APPLICATION: ",APP:DTIME
if (APP["^")!(APP="")
GOTO XMBEX
+1 READ !,"ROUTING IND: ",RI:DTIME
if (RI["^")!(RI="")
GOTO XMBEX
+2 READ !,"DAY NUMBER: ",DN:DTIME
if (DN["^")!(DN="")
GOTO XMBEX
+3 READ !,"SSN: ",SSN:DTIME
if (SSN["^")!(SSN="")
GOTO XMBEX
+4 SET SUB=APP_"/"_RI_" #"_DN
SET TYPE=""
+5 FOR
SET SUB=$ORDER(^XMB(3.9,"B",SUB))
if SUB'[APP
QUIT
WRITE "."
SET XMZ=0
SET XMZ=$ORDER(^XMB(3.9,"B",SUB,XMZ))
SET XMPOS=0
FOR
DO REC^XMS3
if XMER<0
QUIT
Begin DoDot:1
+6 IF XMRG["****PDH"
SET TYPE=XMRG
+7 IF XMRG[SSN
WRITE !!,XMZ_"-"_XMPOS_TYPE,!!,XMRG
End DoDot:1
XMBEX KILL APP,RI,DN,SSN,SUB,TYPE,XMZ,XMRG,XMER,XMPOS
+1 QUIT
FIX READ !,"IEN#1: ",IEN1:DTIME
if (IEN1["^")!(IEN1="")
GOTO FIXEX
+1 READ !,"IEN#2: ",IEN2:DTIME
if (IEN2["^")!(IEN2="")
GOTO FIXEX
+2 SET PPIEN=0
FOR
SET PPIEN=$ORDER(^PRST(459,PPIEN))
if PPIEN'>0
QUIT
IF $DATA(^PRST(459,PPIEN,"P",IEN1))
Begin DoDot:1
+3 WRITE !,"PAY PERIOD ",^PRST(459,PPIEN,0)
+4 SET %X="^PRST(459,PPIEN,""P"","_IEN1_","
+5 SET %Y="^PRST(459,PPIEN,""P"","_IEN2_","
+6 IF '$DATA(^PRST(459,PPIEN,"P",IEN2))
DO %XY^%RCR
SET $PIECE(^PRST(459,PPIEN,"P",IEN2,0),"^",1)=IEN2
SET ^PRST(459,PPIEN,"P","B",IEN2,IEN2)=""
+7 KILL ^PRST(459,PPIEN,"P",IEN1),^PRST(459,PPIEN,"P","B",IEN1,IEN1)
End DoDot:1
+8 SET PPIEN=0
FOR
SET PPIEN=$ORDER(^PRST(455,PPIEN))
if PPIEN'>0
QUIT
IF $DATA(^PRST(455,PPIEN,1,IEN1))
Begin DoDot:1
+9 WRITE !,"PAY PERIOD ",$PIECE(^PRST(455,PPIEN,0),"^",1)
+10 SET %X="^PRST(455,PPIEN,1,"_IEN1_","
+11 SET %Y="^PRST(455,PPIEN,1,"_IEN2_","
+12 IF '$DATA(^PRST(455,PPIEN,1,IEN2))
DO %XY^%RCR
SET $PIECE(^PRST(455,PPIEN,1,IEN2,0),"^",1)=IEN2
SET ^PRST(455,PPIEN,1,"B",IEN2,IEN2)=""
+13 KILL ^PRST(455,PPIEN,1,IEN1),^PRST(455,PPIEN,1,"B",IEN1,IEN1)
End DoDot:1
+14 DO FIXEX
GOTO FIX
FIXEX KILL IEN1,IEN2,PPIEN,%X,%Y
+1 QUIT
