- 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 ---[H[J[2J[HPRCHPOO 1345 printed Mar 13, 2025@21:14:15 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
