- 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 23, 2025@18:40:29 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
