PRCFDPVT ;WISC/LEM/BGJ-PAYMENT ERROR PROCESSING REBUILD/RETRANSMIT ;10/3/95 17:14
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
TYPE(X) N FMSNO,STATUS,STATTXT1,FMSTYPE
S PRC("SITE")=$P(X,U),FMSTYPE=$P(X,U,2)
I ("^PV^MO^SO^"'[("^"_FMSTYPE_"^")) D MSG1^PRCFDPVM,OUT Q
D STAT I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) G EX
I 'PRCFA("ERROR"),'$G(PRCFA("TRANS")) G EX
D NUM^PRCFDPVU W !,"**PONUM=",PONUM,! D GET^PRCFDPVU(421.5,PONUM) I Y<0 D MSG2^PRCFDPVM Q
L:+Y>0 +^PRCF(421.5,+Y):5 E W !,"This Payment Voucher is being edited by someone else, please try later!" R !,"Hit <RETURN> to continue.",Y:DTIME G EX
D TPO
EX D SCREEN K DIRUT,DIROUT,DUOUT,DTOUT,VAR
QUIT
;
STAT S STATUS=GECSDATA(2100.1,GECSDATA,3,"E") D
.I $E(STATUS,1)="T" D STATT^PRCFDPV2 Q
.I $E(STATUS,1)="Q" D STATQ^PRCFDPV2 Q
.I $E(STATUS,1)="M" D STATM^PRCFDPV2 Q
.I $E(STATUS,1)="E" D STATE^PRCFDPV2 Q
.I $E(STATUS,1)="A" D STATA^PRCFDPV2 Q
.I $E(STATUS,1)="R" D STATR^PRCFDPV2 Q
Q
TPO ; Payment Voucher Error Processing when MOP = Invoice/Rec Rep,CI,Req
S (D0,PRCF("CIDA"))=+Y D STATR1^PRCFDPV2
S GO=$P($G(RESP),U) I GO D
. S DIC=421.5
. S (FR,TO)=PRCF("CIDA"),L=0,BY="@.01;",FLDS="[CAPTIONED]",IOP="HOME"
. S PRCF("VIEW")="" D WAIT^PRCFYN,EN1^DIP
. K PRCF("VIEW"),RECORD,RECORD1,DIC,DK
. D PAUSE^PRCFDPVU
. Q
W ! S RETRAN=$$RETRANS^PRCFDPVU
K GO S GO=$P($G(RETRAN),U)
I 'GO D MSG4^PRCFDPVM L -^PRCF(421.5,PRCF("CIDA")) D OUT H 3 Q
I GO D
. S PRCFA("RETRAN")=1
. D EN^PRCFDA3(PRCF("CIDA")),PAUSE^PRCFDPVU
. Q
Q
T1358 ; 1358 Error Processing when MOP = MISC OBL(1358)
D STATR1^PRCFDPV2
D GENDIQ^PRCFFU7(442,+POIEN,".07","I","")
S (OB,DA)=$G(PRCTMP(442,+POIEN,".07","I"))
D NODE^PRCS58OB(DA,.TRNODE)
I '$D(PRC("CP")) S PRC("CP")=$P(TRNODE(0),"-",4)
S GO=$P($G(RESP),U) I GO D
.D PAUSE1^PRCFDPVU
.S IOP="HOME" D ^%ZIS,^PRCE58P0
.Q
W ! S RETRAN=$$RETRANS^PRCFDPVU
K GO S GO=$P($G(RETRAN),U) I 'GO D MSG4^PRCFDPVM,OUT H 3 Q
I GO D
.S PRCFA("RETRAN")=1,DA=OB
.S PRCF("X")="F" D ^PRCFSITE
.D SC^PRCESOE
Q
OUT K GECSDATA,FMSTYPE,FMSNO,STATUS,DIC
Q
SCREEN ; Control screen display
I $D(IOF) W @IOF
HDR ; Write Option Header
I $D(XQY0) W IOINHI,$P(XQY0,U,2),IOINORM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDPVT 2289 printed Nov 22, 2024@17:13:17 Page 2
PRCFDPVT ;WISC/LEM/BGJ-PAYMENT ERROR PROCESSING REBUILD/RETRANSMIT ;10/3/95 17:14
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
TYPE(X) NEW FMSNO,STATUS,STATTXT1,FMSTYPE
+1 SET PRC("SITE")=$PIECE(X,U)
SET FMSTYPE=$PIECE(X,U,2)
+2 IF ("^PV^MO^SO^"'[("^"_FMSTYPE_"^"))
DO MSG1^PRCFDPVM
DO OUT
QUIT
+3 DO STAT
IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)
GOTO EX
+4 IF 'PRCFA("ERROR")
IF '$GET(PRCFA("TRANS"))
GOTO EX
+5 DO NUM^PRCFDPVU
WRITE !,"**PONUM=",PONUM,!
DO GET^PRCFDPVU(421.5,PONUM)
IF Y<0
DO MSG2^PRCFDPVM
QUIT
+6 if +Y>0
LOCK +^PRCF(421.5,+Y):5
IF '$TEST
WRITE !,"This Payment Voucher is being edited by someone else, please try later!"
READ !,"Hit <RETURN> to continue.",Y:DTIME
GOTO EX
+7 DO TPO
EX DO SCREEN
KILL DIRUT,DIROUT,DUOUT,DTOUT,VAR
+1 QUIT
+2 ;
STAT SET STATUS=GECSDATA(2100.1,GECSDATA,3,"E")
Begin DoDot:1
+1 IF $EXTRACT(STATUS,1)="T"
DO STATT^PRCFDPV2
QUIT
+2 IF $EXTRACT(STATUS,1)="Q"
DO STATQ^PRCFDPV2
QUIT
+3 IF $EXTRACT(STATUS,1)="M"
DO STATM^PRCFDPV2
QUIT
+4 IF $EXTRACT(STATUS,1)="E"
DO STATE^PRCFDPV2
QUIT
+5 IF $EXTRACT(STATUS,1)="A"
DO STATA^PRCFDPV2
QUIT
+6 IF $EXTRACT(STATUS,1)="R"
DO STATR^PRCFDPV2
QUIT
End DoDot:1
+7 QUIT
TPO ; Payment Voucher Error Processing when MOP = Invoice/Rec Rep,CI,Req
+1 SET (D0,PRCF("CIDA"))=+Y
DO STATR1^PRCFDPV2
+2 SET GO=$PIECE($GET(RESP),U)
IF GO
Begin DoDot:1
+3 SET DIC=421.5
+4 SET (FR,TO)=PRCF("CIDA")
SET L=0
SET BY="@.01;"
SET FLDS="[CAPTIONED]"
SET IOP="HOME"
+5 SET PRCF("VIEW")=""
DO WAIT^PRCFYN
DO EN1^DIP
+6 KILL PRCF("VIEW"),RECORD,RECORD1,DIC,DK
+7 DO PAUSE^PRCFDPVU
+8 QUIT
End DoDot:1
+9 WRITE !
SET RETRAN=$$RETRANS^PRCFDPVU
+10 KILL GO
SET GO=$PIECE($GET(RETRAN),U)
+11 IF 'GO
DO MSG4^PRCFDPVM
LOCK -^PRCF(421.5,PRCF("CIDA"))
DO OUT
HANG 3
QUIT
+12 IF GO
Begin DoDot:1
+13 SET PRCFA("RETRAN")=1
+14 DO EN^PRCFDA3(PRCF("CIDA"))
DO PAUSE^PRCFDPVU
+15 QUIT
End DoDot:1
+16 QUIT
T1358 ; 1358 Error Processing when MOP = MISC OBL(1358)
+1 DO STATR1^PRCFDPV2
+2 DO GENDIQ^PRCFFU7(442,+POIEN,".07","I","")
+3 SET (OB,DA)=$GET(PRCTMP(442,+POIEN,".07","I"))
+4 DO NODE^PRCS58OB(DA,.TRNODE)
+5 IF '$DATA(PRC("CP"))
SET PRC("CP")=$PIECE(TRNODE(0),"-",4)
+6 SET GO=$PIECE($GET(RESP),U)
IF GO
Begin DoDot:1
+7 DO PAUSE1^PRCFDPVU
+8 SET IOP="HOME"
DO ^%ZIS
DO ^PRCE58P0
+9 QUIT
End DoDot:1
+10 WRITE !
SET RETRAN=$$RETRANS^PRCFDPVU
+11 KILL GO
SET GO=$PIECE($GET(RETRAN),U)
IF 'GO
DO MSG4^PRCFDPVM
DO OUT
HANG 3
QUIT
+12 IF GO
Begin DoDot:1
+13 SET PRCFA("RETRAN")=1
SET DA=OB
+14 SET PRCF("X")="F"
DO ^PRCFSITE
+15 DO SC^PRCESOE
End DoDot:1
+16 QUIT
OUT KILL GECSDATA,FMSTYPE,FMSNO,STATUS,DIC
+1 QUIT
SCREEN ; Control screen display
+1 IF $DATA(IOF)
WRITE @IOF
HDR ; Write Option Header
+1 IF $DATA(XQY0)
WRITE IOINHI,$PIECE(XQY0,U,2),IOINORM
+2 QUIT
