- PRCOER4 ;WIRMFO-EDI EXCEPTIONS REPORT ; [8/31/98 1:51pm]
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- W @IOF
- D RT^PRCOER1 ;ask user date range
- I $S('$G(PRCOBEG):1,'$G(PRCOSTOP):1,1:0) G STOP^PRCOER2
- ;
- S ZTSAVE("PRCOBEG")=""
- S ZTSAVE("PRCOSTOP")=""
- S ZTSAVE("SENDER")=""
- S ZTRTN="START^PRCOER4"
- S ZTDESC="EC/EDI Exceptions Report"
- D ZIS^PRCOER2
- I $G(POP) G STOP^PRCOER2
- I $G(PRCOPOP) G STOP^PRCOER2
- ;
- START ; entry to generate Exceptions Report
- ;
- U IO
- I $E(IOST,1,2)="C-" W @IOF
- ; this section gathers all errors sent from Austin
- D HED
- D PRJ
- I '$G(PRCOUT),$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR G QUIT:$G(DIRUT)
- W @IOF
- D HED
- D POA
- ;
- QUIT K DUOUT,DIRUT,DTOUT,IT,PO,PRCO,CNT G STOP^PRCOER2 ;return to list manager control
- ;
- PRJ N I,J,PRCO
- D HEDPRJ
- I SENDER=0 S I=PRCOBEG F S I=$O(^PRC(443.75,"AL",2,"PRJ",I)) Q:'I!(I>PRCOSTOP)!($G(PRCOUT)) D
- . S J=0 F S J=$O(^PRC(443.75,"AL",2,"PRJ",I,J)) Q:'J!($G(PRCOUT)) S PRCO(0)=$G(^PRC(443.75,J,0)),PRCO(1)=^(1) D DISPLAY S CNT=1
- I SENDER>0 S I=PRCOBEG F S I=$O(^PRC(443.75,"AL1",2,SENDER,"PRJ",I)) Q:'I!(I>PRCOSTOP)!($G(PRCOUT)) D
- . S J=0 F S J=$O(^PRC(443.75,"AL1",2,SENDER,"PRJ",I,J)) Q:'J!($G(PRCOUT)) S PRCO(0)=$G(^PRC(443.75,J,0)),PRCO(1)=^(1) D DISPLAY S CNT=1
- I '$G(CNT) D NORECORD
- Q
- ;
- DISPLAY ; Come here to show a PRJ exception to the user.
- ;
- W !,?1,$P(PRCO(0),U,2),?22,$P(PRCO(0),U,6),?36,$$FMTE^XLFDT($P(PRCO(1),U,2),2),?64,$E($P(PRCO(1),U,3),1,25)
- W !?2,$P(PRCO(1),U,4),?30,$P(PRCO(1),U,6),?38,$P(PRCO(1),U,8),?50,$P(PRCO(1),U,9),?62,$P(PRCO(1),U,10),?73,$P(PRCO(1),U,14)
- I $P(PRCO(1),U,5)]"" W !?4,$P(PRCO(1),U,5)
- I $P(PRCO(1),U,7) W !?4,"Reject Reason Code: ",$P($G(^PRC(443.76,+$P(PRCO(1),U,7),0)),U,2)
- D HANG Q:$G(PRCOUT)
- I $Y+5>IOSL W @IOF D HED,HEDPRJ
- Q
- ;
- POA N I,J,PRCO
- K PRCOUT,CNT
- D HEDPOA
- S I=PRCOBEG F S I=$O(^PRC(443.75,"AM",3,"POA",I)) Q:'I!(I>PRCOSTOP)!($G(PRCOUT)) D
- . S J=0 F S J=$O(^PRC(443.75,"AM",3,"POA",I,J)) Q:'J!($G(PRCOUT)) S PRCO(0)=$G(^PRC(443.75,J,0)),PRCO(1)=^(1) D
- .. S PO=+$P(PRCO(0),U,8) Q:$G(^PRC(442,PO,0))']"" D DISPLAY1
- I '$G(CNT) D NORECORD
- Q
- ;
- DISPLAY1 ; Come here to show a POA exception to a user.
- ;
- Q:$P(PRCO(1),U,6)']"" S IT=$O(^PRC(442,PO,2,"B",$P(PRCO(1),U,6),0)) Q:IT=""
- S PRCO(2)=$G(^PRC(442,+PO,2,+IT,0)),PRCO(3)=$G(^(2))
- Q:$P($G(PRCO(3)),U,9)="AC"
- Q:$P($G(PRCO(3)),U,11)="AC"
- S CNT=1
- W !?2,$P(PRCO(0),U,2),?26,$P(PRCO(1),U,6),?48,$P(^PRCD(420.5,+$P(PRCO(2),U,3),0),U,2)
- W !?3,$P(PRCO(2),U,2),?15,$S($P(PRCO(3),U,12):$P(PRCO(3),U,12),1:$P(PRCO(3),U,10))
- W ?27,$S($P(PRCO(3),U,11)]"":$$CODE($P(PRCO(3),U,11)),1:$$CODE($P(PRCO(3),U,9)))
- D ERR
- D HANG Q:$G(PRCOUT)
- I $Y+5>IOSL W @IOF D HED,HEDPOA
- Q
- ;
- HED ; used to print main header for exception report.
- W !!
- S HEADER=$S(SENDER=0:"EC/EDI EXCEPTION REPORT",1:"EC/EDI EXCEPTION REPORT for "_$P($G(^VA(200,SENDER,0)),U))
- W $$CJ^XLFSTR(HEADER,$S($G(IOM):IOM,1:80)),!
- W $$CJ^XLFSTR($$REPEAT^XLFSTR("-",$L(HEADER)),$S($G(IOM):IOM,1:80)),!
- W !?2,"Date Range for Report: ",$$FMTE^XLFDT(PRCOBEG)_" to "_$$FMTE^XLFDT(PRCOSTOP),!
- Q
- HEDPRJ ; write header for PRJ data
- W !,$$CJ^XLFSTR(">>>> PRJ EXCEPTIONS <<<<",$S($G(IOM):IOM,1:80))
- W !!?1,"REFERENCE #",?22,"VENDOR ID",?36,"DATE/TIME PROCESSED",?59,"INCORRECT SEGMENT"
- W !?2,"INCORRECT FIELD",?30,"LINE#",?38,"DESC-LINE#",?50,"DE-SEQ#",?62,"CO-SEQ#",?73,"SEQ #"
- W !?4,"FIELD CONTENTS"
- W !,$$REPEAT^XLFSTR("=",$S($G(IOM):IOM,1:80))
- Q
- ;
- HEDPOA ; write header for POA exceptions
- W !,$$CJ^XLFSTR(">>>> POA EXCEPTIONS <<<<",$S($G(IOM):IOM,1:80))
- W !!?1,"REFERENCE #",?24,"LINE ITEM #",?47,"UNIT OF PURCHASE"
- W !?2,"QTY ORDERED",?15,"QTY EXCEPTED",?29,"EXCEPTION REASON"
- W !,$$REPEAT^XLFSTR("=",$S($G(IOM):IOM,1:80))
- Q
- ;
- HANG ; call at end of screen if output sent to screen
- ; returns 'PRCOUT'=1 if user enter '^'
- N DIRUT,DUOUT,DTOUT
- K PRCOUT
- I $Y+5>IOSL,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y PRCOUT=1 Q:$G(PRCOUT)
- ;
- ; I $Y+5>IOSL W @IOF D HED
- ;
- Q
- ;
- CODE(X) ; returns external value of set of codes from field 442.01,13
- ; X = what is stored
- I $G(X)']"" Q ""
- N Y,C
- S Y=X
- S C=$P(^DD(442.01,13,0),U,2)
- D Y^DIQ
- Q Y
- ;
- ERR ; write out incoming processing errors
- ;
- Q:'$O(^PRC(443.75,J,"ERR",0))
- W !?8,">>> Incoming processing errors <<<"
- N I S I=0
- F S I=$O(^PRC(443.75,J,"ERR",I)) Q:'I W !?2,"- ",$G(^(I,0))
- Q
- ;
- NORECORD ; write no data to report
- W !!?3,"No records meet the selection criteria.",!
- Q
- ;
- PO ; display selected PURCHASE ORDER
- S MESS="Enter the line number of the PO/RFQ"
- D MSG^VALM10(MESS)
- W !!!!
- AGAIN W !,"LINE NUMBER: " R PONUM:DTIME
- I PONUM["^"!(PONUM="") G FINI
- I PONUM'?1.N!(PONUM<1) W !!,?6," Please enter the line number next to the PO/RFQ Number.",$C(7),! G AGAIN
- I PONUM>VALMCNT W !!,?6," Response must be no greater than "_VALMCNT_".",$C(7),! G AGAIN
- S PONUM1=$P($G(^PRC(443.75,"PRCOER",$J,PONUM)),U,2)
- S PONUM2=$G(^PRC(443.75,PONUM1,0))
- I PONUM2="" W !,"THE ENTRY IN FILE 443.75 IS MISSING" G FINI
- S PRC("SITE")=$P($P(PONUM2,U,2),"-",1)
- I $P(PONUM2,"-",3)="RFQ" W !!,?6," Please use option View RFQ [PRCHQ15] to review this line item.",$C(7),! G AGAIN
- S D0=$P(PONUM2,U,8)
- D CLEAR^VALM1
- D ^PRCHDP1
- FINI D PAUSE^VALM1
- S VALMBCK="R"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOER4 5389 printed Feb 18, 2025@23:38:20 Page 2
- PRCOER4 ;WIRMFO-EDI EXCEPTIONS REPORT ; [8/31/98 1:51pm]
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 WRITE @IOF
- +5 ;ask user date range
- DO RT^PRCOER1
- +6 IF $SELECT('$GET(PRCOBEG):1,'$GET(PRCOSTOP):1,1:0)
- GOTO STOP^PRCOER2
- +7 ;
- +8 SET ZTSAVE("PRCOBEG")=""
- +9 SET ZTSAVE("PRCOSTOP")=""
- +10 SET ZTSAVE("SENDER")=""
- +11 SET ZTRTN="START^PRCOER4"
- +12 SET ZTDESC="EC/EDI Exceptions Report"
- +13 DO ZIS^PRCOER2
- +14 IF $GET(POP)
- GOTO STOP^PRCOER2
- +15 IF $GET(PRCOPOP)
- GOTO STOP^PRCOER2
- +16 ;
- START ; entry to generate Exceptions Report
- +1 ;
- +2 USE IO
- +3 IF $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +4 ; this section gathers all errors sent from Austin
- +5 DO HED
- +6 DO PRJ
- +7 IF '$GET(PRCOUT)
- IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if $GET(DIRUT)
- GOTO QUIT
- +8 WRITE @IOF
- +9 DO HED
- +10 DO POA
- +11 ;
- QUIT ;return to list manager control
- KILL DUOUT,DIRUT,DTOUT,IT,PO,PRCO,CNT
- GOTO STOP^PRCOER2
- +1 ;
- PRJ NEW I,J,PRCO
- +1 DO HEDPRJ
- +2 IF SENDER=0
- SET I=PRCOBEG
- FOR
- SET I=$ORDER(^PRC(443.75,"AL",2,"PRJ",I))
- if 'I!(I>PRCOSTOP)!($GET(PRCOUT))
- QUIT
- Begin DoDot:1
- +3 SET J=0
- FOR
- SET J=$ORDER(^PRC(443.75,"AL",2,"PRJ",I,J))
- if 'J!($GET(PRCOUT))
- QUIT
- SET PRCO(0)=$GET(^PRC(443.75,J,0))
- SET PRCO(1)=^(1)
- DO DISPLAY
- SET CNT=1
- End DoDot:1
- +4 IF SENDER>0
- SET I=PRCOBEG
- FOR
- SET I=$ORDER(^PRC(443.75,"AL1",2,SENDER,"PRJ",I))
- if 'I!(I>PRCOSTOP)!($GET(PRCOUT))
- QUIT
- Begin DoDot:1
- +5 SET J=0
- FOR
- SET J=$ORDER(^PRC(443.75,"AL1",2,SENDER,"PRJ",I,J))
- if 'J!($GET(PRCOUT))
- QUIT
- SET PRCO(0)=$GET(^PRC(443.75,J,0))
- SET PRCO(1)=^(1)
- DO DISPLAY
- SET CNT=1
- End DoDot:1
- +6 IF '$GET(CNT)
- DO NORECORD
- +7 QUIT
- +8 ;
- DISPLAY ; Come here to show a PRJ exception to the user.
- +1 ;
- +2 WRITE !,?1,$PIECE(PRCO(0),U,2),?22,$PIECE(PRCO(0),U,6),?36,$$FMTE^XLFDT($PIECE(PRCO(1),U,2),2),?64,$EXTRACT($PIECE(PRCO(1),U,3),1,25)
- +3 WRITE !?2,$PIECE(PRCO(1),U,4),?30,$PIECE(PRCO(1),U,6),?38,$PIECE(PRCO(1),U,8),?50,$PIECE(PRCO(1),U,9),?62,$PIECE(PRCO(1),U,10),?73,$PIECE(PRCO(1),U,14)
- +4 IF $PIECE(PRCO(1),U,5)]""
- WRITE !?4,$PIECE(PRCO(1),U,5)
- +5 IF $PIECE(PRCO(1),U,7)
- WRITE !?4,"Reject Reason Code: ",$PIECE($GET(^PRC(443.76,+$PIECE(PRCO(1),U,7),0)),U,2)
- +6 DO HANG
- if $GET(PRCOUT)
- QUIT
- +7 IF $Y+5>IOSL
- WRITE @IOF
- DO HED
- DO HEDPRJ
- +8 QUIT
- +9 ;
- POA NEW I,J,PRCO
- +1 KILL PRCOUT,CNT
- +2 DO HEDPOA
- +3 SET I=PRCOBEG
- FOR
- SET I=$ORDER(^PRC(443.75,"AM",3,"POA",I))
- if 'I!(I>PRCOSTOP)!($GET(PRCOUT))
- QUIT
- Begin DoDot:1
- +4 SET J=0
- FOR
- SET J=$ORDER(^PRC(443.75,"AM",3,"POA",I,J))
- if 'J!($GET(PRCOUT))
- QUIT
- SET PRCO(0)=$GET(^PRC(443.75,J,0))
- SET PRCO(1)=^(1)
- Begin DoDot:2
- +5 SET PO=+$PIECE(PRCO(0),U,8)
- if $GET(^PRC(442,PO,0))']""
- QUIT
- DO DISPLAY1
- End DoDot:2
- End DoDot:1
- +6 IF '$GET(CNT)
- DO NORECORD
- +7 QUIT
- +8 ;
- DISPLAY1 ; Come here to show a POA exception to a user.
- +1 ;
- +2 if $PIECE(PRCO(1),U,6)']""
- QUIT
- SET IT=$ORDER(^PRC(442,PO,2,"B",$PIECE(PRCO(1),U,6),0))
- if IT=""
- QUIT
- +3 SET PRCO(2)=$GET(^PRC(442,+PO,2,+IT,0))
- SET PRCO(3)=$GET(^(2))
- +4 if $PIECE($GET(PRCO(3)),U,9)="AC"
- QUIT
- +5 if $PIECE($GET(PRCO(3)),U,11)="AC"
- QUIT
- +6 SET CNT=1
- +7 WRITE !?2,$PIECE(PRCO(0),U,2),?26,$PIECE(PRCO(1),U,6),?48,$PIECE(^PRCD(420.5,+$PIECE(PRCO(2),U,3),0),U,2)
- +8 WRITE !?3,$PIECE(PRCO(2),U,2),?15,$SELECT($PIECE(PRCO(3),U,12):$PIECE(PRCO(3),U,12),1:$PIECE(PRCO(3),U,10))
- +9 WRITE ?27,$SELECT($PIECE(PRCO(3),U,11)]"":$$CODE($PIECE(PRCO(3),U,11)),1:$$CODE($PIECE(PRCO(3),U,9)))
- +10 DO ERR
- +11 DO HANG
- if $GET(PRCOUT)
- QUIT
- +12 IF $Y+5>IOSL
- WRITE @IOF
- DO HED
- DO HEDPOA
- +13 QUIT
- +14 ;
- HED ; used to print main header for exception report.
- +1 WRITE !!
- +2 SET HEADER=$SELECT(SENDER=0:"EC/EDI EXCEPTION REPORT",1:"EC/EDI EXCEPTION REPORT for "_$PIECE($GET(^VA(200,SENDER,0)),U))
- +3 WRITE $$CJ^XLFSTR(HEADER,$SELECT($GET(IOM):IOM,1:80)),!
- +4 WRITE $$CJ^XLFSTR($$REPEAT^XLFSTR("-",$LENGTH(HEADER)),$SELECT($GET(IOM):IOM,1:80)),!
- +5 WRITE !?2,"Date Range for Report: ",$$FMTE^XLFDT(PRCOBEG)_" to "_$$FMTE^XLFDT(PRCOSTOP),!
- +6 QUIT
- HEDPRJ ; write header for PRJ data
- +1 WRITE !,$$CJ^XLFSTR(">>>> PRJ EXCEPTIONS <<<<",$SELECT($GET(IOM):IOM,1:80))
- +2 WRITE !!?1,"REFERENCE #",?22,"VENDOR ID",?36,"DATE/TIME PROCESSED",?59,"INCORRECT SEGMENT"
- +3 WRITE !?2,"INCORRECT FIELD",?30,"LINE#",?38,"DESC-LINE#",?50,"DE-SEQ#",?62,"CO-SEQ#",?73,"SEQ #"
- +4 WRITE !?4,"FIELD CONTENTS"
- +5 WRITE !,$$REPEAT^XLFSTR("=",$SELECT($GET(IOM):IOM,1:80))
- +6 QUIT
- +7 ;
- HEDPOA ; write header for POA exceptions
- +1 WRITE !,$$CJ^XLFSTR(">>>> POA EXCEPTIONS <<<<",$SELECT($GET(IOM):IOM,1:80))
- +2 WRITE !!?1,"REFERENCE #",?24,"LINE ITEM #",?47,"UNIT OF PURCHASE"
- +3 WRITE !?2,"QTY ORDERED",?15,"QTY EXCEPTED",?29,"EXCEPTION REASON"
- +4 WRITE !,$$REPEAT^XLFSTR("=",$SELECT($GET(IOM):IOM,1:80))
- +5 QUIT
- +6 ;
- HANG ; call at end of screen if output sent to screen
- +1 ; returns 'PRCOUT'=1 if user enter '^'
- +2 NEW DIRUT,DUOUT,DTOUT
- +3 KILL PRCOUT
- +4 IF $Y+5>IOSL
- IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET PRCOUT=1
- if $GET(PRCOUT)
- QUIT
- +5 ;
- +6 ; I $Y+5>IOSL W @IOF D HED
- +7 ;
- +8 QUIT
- +9 ;
- CODE(X) ; returns external value of set of codes from field 442.01,13
- +1 ; X = what is stored
- +2 IF $GET(X)']""
- QUIT ""
- +3 NEW Y,C
- +4 SET Y=X
- +5 SET C=$PIECE(^DD(442.01,13,0),U,2)
- +6 DO Y^DIQ
- +7 QUIT Y
- +8 ;
- ERR ; write out incoming processing errors
- +1 ;
- +2 if '$ORDER(^PRC(443.75,J,"ERR",0))
- QUIT
- +3 WRITE !?8,">>> Incoming processing errors <<<"
- +4 NEW I
- SET I=0
- +5 FOR
- SET I=$ORDER(^PRC(443.75,J,"ERR",I))
- if 'I
- QUIT
- WRITE !?2,"- ",$GET(^(I,0))
- +6 QUIT
- +7 ;
- NORECORD ; write no data to report
- +1 WRITE !!?3,"No records meet the selection criteria.",!
- +2 QUIT
- +3 ;
- PO ; display selected PURCHASE ORDER
- +1 SET MESS="Enter the line number of the PO/RFQ"
- +2 DO MSG^VALM10(MESS)
- +3 WRITE !!!!
- AGAIN WRITE !,"LINE NUMBER: "
- READ PONUM:DTIME
- +1 IF PONUM["^"!(PONUM="")
- GOTO FINI
- +2 IF PONUM'?1.N!(PONUM<1)
- WRITE !!,?6," Please enter the line number next to the PO/RFQ Number.",$CHAR(7),!
- GOTO AGAIN
- +3 IF PONUM>VALMCNT
- WRITE !!,?6," Response must be no greater than "_VALMCNT_".",$CHAR(7),!
- GOTO AGAIN
- +4 SET PONUM1=$PIECE($GET(^PRC(443.75,"PRCOER",$JOB,PONUM)),U,2)
- +5 SET PONUM2=$GET(^PRC(443.75,PONUM1,0))
- +6 IF PONUM2=""
- WRITE !,"THE ENTRY IN FILE 443.75 IS MISSING"
- GOTO FINI
- +7 SET PRC("SITE")=$PIECE($PIECE(PONUM2,U,2),"-",1)
- +8 IF $PIECE(PONUM2,"-",3)="RFQ"
- WRITE !!,?6," Please use option View RFQ [PRCHQ15] to review this line item.",$CHAR(7),!
- GOTO AGAIN
- +9 SET D0=$PIECE(PONUM2,U,8)
- +10 DO CLEAR^VALM1
- +11 DO ^PRCHDP1
- FINI DO PAUSE^VALM1
- +1 SET VALMBCK="R"
- +2 QUIT