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 Dec 13, 2024@02:09:28 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
