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