PRCHPOO.m

PRCHPOO ;WISC/TGH-GENERATE PROOF OF ORDER FOR GUARANTEED DELIVERY P.O.'S ;7/18/95  12:06

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

EN W $C(7),!!,"Now Generating Proof of Order (Receiving Report) for Guaranteed Delivery",!,"P.O.       (please wait...)",!!!

 I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)

 S PRCHPO=PRCFA("PODA"),PRCHRD=DT,PRCHRT0="",(PRCHRT,PRCHRFIN)=0,X=$P(^PRC(442,PRCHPO,0),U,19) D:X'=2 TM^PRCHREC2

 K PRCHR S X="C",PRCHPOO=1 D COM1^PRCHREC1

 K PRCHPOO

 ;ELECTRONICALLY TRANSMIT RR TO AUSTIN

 I $G(PRCFA("PODA"))>0,$D(PRCFA("PARTIAL")) D

 . D:'$G(PRCFA("RETRAN"))

 . . N PNO,XA,XB,XC,XD,GECSFMS,POESIG

 . . S PNO="" D ALPHA^PRCFPAR(PRCFA("PARTIAL"),.PNO)

 . . S XD=$P($G(^PRC(442,PRCFA("PODA"),0)),U),GECSFMS("DA")=""

 . . S GECSFMS("DOC")="^^RR^"_$TR(XD,"-")_PNO,POESIG=1,XA="RR",XB="E"

 . . S XC=$P($G(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0)),U)

 . . S XD=$P(XD,"-",2) K PRCFA("TT")

 . . D EN7^PRCFFU41(XA,XB,XC,XD)

 . S DA=PRCFA("PARTIAL"),DA(1)=PRCFA("PODA"),DIE="^PRC(442,"_DA(1)_",11,"

 . S DR="23R//^S X=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",U,$E(DT,4,5))_"" ""_($E(DT,1,3)+1700)"

 . D ^DIE K DA,DIE,DR Q:$D(DTOUT)!$D(DUOUT)!$D(Y)

 . D LOAD^PRCFARRQ

 K %Y,B,DG,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DR,FSO,P,Q,Q1,S,X,Y

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHPOO   1345     printed  Apr 09, 2024@21:09:36                                                                                                                                                                                                     Page 2

PRCHPOO   ;WISC/TGH-GENERATE PROOF OF ORDER FOR GUARANTEED DELIVERY P.O.'S ;7/18/95  12:06

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

EN         WRITE $CHAR(7),!!,"Now Generating Proof of Order (Receiving Report) for Guaranteed Delivery",!,"P.O.       (please wait...)",!!!

 +1        IF '$DATA(DT)

               DO NOW^%DTC

               SET DT=$PIECE(%,".",1)

 +2        SET PRCHPO=PRCFA("PODA")

           SET PRCHRD=DT

           SET PRCHRT0=""

           SET (PRCHRT,PRCHRFIN)=0

           SET X=$PIECE(^PRC(442,PRCHPO,0),U,19)

           if X'=2

               DO TM^PRCHREC2

 +3        KILL PRCHR

           SET X="C"

           SET PRCHPOO=1

           DO COM1^PRCHREC1

 +4        KILL PRCHPOO

 +5       ;ELECTRONICALLY TRANSMIT RR TO AUSTIN

 +6        IF $GET(PRCFA("PODA"))>0

               IF $DATA(PRCFA("PARTIAL"))

                   Begin DoDot:1

 +7                    if '$GET(PRCFA("RETRAN"))

                           Begin DoDot:2

 +8                            NEW PNO,XA,XB,XC,XD,GECSFMS,POESIG

 +9                            SET PNO=""

                               DO ALPHA^PRCFPAR(PRCFA("PARTIAL"),.PNO)

 +10                           SET XD=$PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U)

                               SET GECSFMS("DA")=""

 +11                           SET GECSFMS("DOC")="^^RR^"_$TRANSLATE(XD,"-")_PNO

                               SET POESIG=1

                               SET XA="RR"

                               SET XB="E"

 +12                           SET XC=$PIECE($GET(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0)),U)

 +13                           SET XD=$PIECE(XD,"-",2)

                               KILL PRCFA("TT")

 +14                           DO EN7^PRCFFU41(XA,XB,XC,XD)

                           End DoDot:2

 +15                   SET DA=PRCFA("PARTIAL")

                       SET DA(1)=PRCFA("PODA")

                       SET DIE="^PRC(442,"_DA(1)_",11,"

 +16                   SET DR="23R//^S X=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",U,$E(DT,4,5))_"" ""_($E(DT,1,3)+1700)"

 +17                   DO ^DIE

                       KILL DA,DIE,DR

                       if $DATA(DTOUT)!$DATA(DUOUT)!$DATA(Y)

                           QUIT 

 +18                   DO LOAD^PRCFARRQ

                   End DoDot:1

 +19       KILL %Y,B,DG,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DR,FSO,P,Q,Q1,S,X,Y

 +20       QUIT