PRCFAC02 ;WISC@ALTOONA/CTB/BGJ-CONTINUATION OF PRCFAC01 ;11/17/94 09:37
V ;;5.1;IFCAP;**14,179**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*179 Rearrange processing path to insure 410 obligation
; is done before print calls based on MOP. Users
; were capable of exiting MOP print call without
; returning to 410 obligating call.
;
S PRCFA("MOP")=$P(^PRC(442,PRCFA("PODA"),0),"^",2) I 123478'[PRCFA("MOP") Q
I '$D(PRCHDELV) S COPY=1,PRCF("DEST")="S8" S:PRCFA("MOP")=8 PRCF("DEST")="S" D OBD ;PRC*179 410 obligation call moved
I PRCFA("MOP") D @PRCFA("MOP")
I $D(PRCHDELV) I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)'=2 S COPY=1 D PRINT
K COPY Q
1 ;INVOICE/RR
D OBL
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)'=2 D
.S COPY=1,PRCF("DEST")="S8"
.S DIR("A")="Do you wish to queue this order to another printer"
.S DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR
.I Y<0!($D(DIRUT)) S PRCFA("XTRA")=0
.I Y=1 S PRCFA("XTRA")=1
.D PRINT
.Q
Q
;
2 ;CERTIFIED INVOICE
D TC
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2 Q
S COPY=1,PRCF("DEST")="S8" D PRINT Q
3 ;PAYMENT IN ADVANCE
D TC
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2 Q
S COPY=1,PRCF("DEST")="S8" D PRINT
S COPY=3,PRCF("DEST")="F" D P1 Q
7 ;IMPREST FUND
D OBL
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2 Q
S COPY=1,PRCF("DEST")="S8" D PRINT Q
8 ;REQUISITION
D OBL
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2 Q
S COPY=1,PRCF("DEST")="S" D PRINT Q
4 ;GUARANTEED DELIVERY
D TC,^PRCHPOO
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2 Q
S COPY=1,PRCF("DEST")="S8" D PRINT Q
;
S X="Unable to print Fiscal Copy. Use reprint option if copy is required.*" D MSG^PRCFQ Q
OBL ;MARK AS "OBLIGATED"
S FSO=$P(^PRC(442,PRCFA("PODA"),7),U,1) S:FSO="" FSO=10 S FSO=$P(^PRCD(442.3,FSO,0),"^",3)+15,X=FSO,DA=PRCFA("PODA") D ENF^PRCHSTAT
K FSO Q
TC ;MARK PO AS "TRANSACTION COMPLETE"
S X=40,DA=PRCFA("PODA") D ENF^PRCHSTAT Q
OAI ;MARK AS "OBLIGATED - AWAITING INVOICE"
S X=42,DA=PRCFA("PODA") D ENF^PRCHSTAT Q
OBD ;PASS OBLIGATION DATA TO CPA MODULE AND PO
K PODA I $S('$D(PRCFA("PODA")):1,'$D(^PRC(442,PRCFA("PODA"),0)):1,1:0) D OUT Q
S PODA=PRCFA("PODA"),PO(0)=^PRC(442,PODA,0)
S AMT=+$S($P(PRCFMO,"^",12)="N":$P(PO(0),"^",16),1:$P(PO(0),"^",15))
S DEL=$P(PO(0),"^",10),TRDA=$P(PO(0),"^",12) D NOW^%DTC S TIME=X
I TRDA="" G:$P($G(^PRC(442,PRCFA("PODA"),0)),U,19)'=2 PRINT Q
I '$D(^PRCS(410,TRDA,4)) D OUT Q
S X=$P(^PRCS(410,TRDA,4),"^",8),DA=TRDA D TRANK^PRCSES
S $P(^PRCS(410,TRDA,9),"^",2)=DEL
S X=(^PRCS(410,TRDA,4))
S $P(X,"^",3,4)=AMT_"^"_TIME
S $P(X,"^",8)=AMT
S (^PRCS(410,TRDA,4))=X
S MESSAGE=""
D ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
K MESSAGE
S X=AMT
D TRANS1^PRCSES,TRANS^PRCSES
I $P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2 Q
PRINT ;PRINT PO
I $D(^PRC(442,PRCFA("PODA"),12)),$P(^(12),"^")]"" Q
D NOW^PRCFQ K %X,X,Y S $P(^PRC(442,PRCFA("PODA"),12),"^")=%
P1 ;
F PRCFI=1:1:COPY S PRCHQ("DEST")=PRCF("DEST"),D0=PRCFA("PODA"),PRCHQ="^PRCHFPNT" D ^PRCHQUE
I $D(PRCFA("XTRA")),PRCFA("XTRA")=1 S PRCHQ="^PRCHFPNT",D0=PRCFA("PODA") D ^PRCHQUE
S PRC("BBFY")=PRCFA("BBFY")
Q
OUT K CSDA,PODA,AMT,CS,PO(0),DEL,TRDA,DA,TIME S X="No data posted to Control Point Files*" D MSG^PRCFQ Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC02 3331 printed Oct 16, 2024@18:02:35 Page 2
PRCFAC02 ;WISC@ALTOONA/CTB/BGJ-CONTINUATION OF PRCFAC01 ;11/17/94 09:37
V ;;5.1;IFCAP;**14,179**;Oct 20, 2000;Build 6
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*179 Rearrange processing path to insure 410 obligation
+4 ; is done before print calls based on MOP. Users
+5 ; were capable of exiting MOP print call without
+6 ; returning to 410 obligating call.
+7 ;
+8 SET PRCFA("MOP")=$PIECE(^PRC(442,PRCFA("PODA"),0),"^",2)
IF 123478'[PRCFA("MOP")
QUIT
+9 ;PRC*179 410 obligation call moved
IF '$DATA(PRCHDELV)
SET COPY=1
SET PRCF("DEST")="S8"
if PRCFA("MOP")=8
SET PRCF("DEST")="S"
DO OBD
+10 IF PRCFA("MOP")
DO @PRCFA("MOP")
+11 IF $DATA(PRCHDELV)
IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)'=2
SET COPY=1
DO PRINT
+12 KILL COPY
QUIT
1 ;INVOICE/RR
+1 DO OBL
+2 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)'=2
Begin DoDot:1
+3 SET COPY=1
SET PRCF("DEST")="S8"
+4 SET DIR("A")="Do you wish to queue this order to another printer"
+5 SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
+6 IF Y<0!($DATA(DIRUT))
SET PRCFA("XTRA")=0
+7 IF Y=1
SET PRCFA("XTRA")=1
+8 DO PRINT
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
2 ;CERTIFIED INVOICE
+1 DO TC
+2 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2
QUIT
+3 SET COPY=1
SET PRCF("DEST")="S8"
DO PRINT
QUIT
3 ;PAYMENT IN ADVANCE
+1 DO TC
+2 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2
QUIT
+3 SET COPY=1
SET PRCF("DEST")="S8"
DO PRINT
+4 SET COPY=3
SET PRCF("DEST")="F"
DO P1
QUIT
7 ;IMPREST FUND
+1 DO OBL
+2 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2
QUIT
+3 SET COPY=1
SET PRCF("DEST")="S8"
DO PRINT
QUIT
8 ;REQUISITION
+1 DO OBL
+2 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2
QUIT
+3 SET COPY=1
SET PRCF("DEST")="S"
DO PRINT
QUIT
4 ;GUARANTEED DELIVERY
+1 DO TC
DO ^PRCHPOO
+2 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2
QUIT
+3 SET COPY=1
SET PRCF("DEST")="S8"
DO PRINT
QUIT
+4 ;
+5 SET X="Unable to print Fiscal Copy. Use reprint option if copy is required.*"
DO MSG^PRCFQ
QUIT
OBL ;MARK AS "OBLIGATED"
+1 SET FSO=$PIECE(^PRC(442,PRCFA("PODA"),7),U,1)
if FSO=""
SET FSO=10
SET FSO=$PIECE(^PRCD(442.3,FSO,0),"^",3)+15
SET X=FSO
SET DA=PRCFA("PODA")
DO ENF^PRCHSTAT
+2 KILL FSO
QUIT
TC ;MARK PO AS "TRANSACTION COMPLETE"
+1 SET X=40
SET DA=PRCFA("PODA")
DO ENF^PRCHSTAT
QUIT
OAI ;MARK AS "OBLIGATED - AWAITING INVOICE"
+1 SET X=42
SET DA=PRCFA("PODA")
DO ENF^PRCHSTAT
QUIT
OBD ;PASS OBLIGATION DATA TO CPA MODULE AND PO
+1 KILL PODA
IF $SELECT('$DATA(PRCFA("PODA")):1,'$DATA(^PRC(442,PRCFA("PODA"),0)):1,1:0)
DO OUT
QUIT
+2 SET PODA=PRCFA("PODA")
SET PO(0)=^PRC(442,PODA,0)
+3 SET AMT=+$SELECT($PIECE(PRCFMO,"^",12)="N":$PIECE(PO(0),"^",16),1:$PIECE(PO(0),"^",15))
+4 SET DEL=$PIECE(PO(0),"^",10)
SET TRDA=$PIECE(PO(0),"^",12)
DO NOW^%DTC
SET TIME=X
+5 IF TRDA=""
if $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)'=2
GOTO PRINT
QUIT
+6 IF '$DATA(^PRCS(410,TRDA,4))
DO OUT
QUIT
+7 SET X=$PIECE(^PRCS(410,TRDA,4),"^",8)
SET DA=TRDA
DO TRANK^PRCSES
+8 SET $PIECE(^PRCS(410,TRDA,9),"^",2)=DEL
+9 SET X=(^PRCS(410,TRDA,4))
+10 SET $PIECE(X,"^",3,4)=AMT_"^"_TIME
+11 SET $PIECE(X,"^",8)=AMT
+12 SET (^PRCS(410,TRDA,4))=X
+13 SET MESSAGE=""
+14 DO ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
+15 KILL MESSAGE
+16 SET X=AMT
+17 DO TRANS1^PRCSES
DO TRANS^PRCSES
+18 IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2
QUIT
PRINT ;PRINT PO
+1 IF $DATA(^PRC(442,PRCFA("PODA"),12))
IF $PIECE(^(12),"^")]""
QUIT
+2 DO NOW^PRCFQ
KILL %X,X,Y
SET $PIECE(^PRC(442,PRCFA("PODA"),12),"^")=%
P1 ;
+1 FOR PRCFI=1:1:COPY
SET PRCHQ("DEST")=PRCF("DEST")
SET D0=PRCFA("PODA")
SET PRCHQ="^PRCHFPNT"
DO ^PRCHQUE
+2 IF $DATA(PRCFA("XTRA"))
IF PRCFA("XTRA")=1
SET PRCHQ="^PRCHFPNT"
SET D0=PRCFA("PODA")
DO ^PRCHQUE
+3 SET PRC("BBFY")=PRCFA("BBFY")
+4 QUIT
OUT KILL CSDA,PODA,AMT,CS,PO(0),DEL,TRDA,DA,TIME
SET X="No data posted to Control Point Files*"
DO MSG^PRCFQ
QUIT
+1 QUIT
