Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCFAC02

PRCFAC02.m

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