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

PRCGARC1.m

Go to the documentation of this file.
  1. PRCGARC1 ;WIRMFO@ALTOONA/CTB/BGJ - IFCAP ARCHIVE SUBROUTINES ;12/10/97 9:04 AM
  1. V ;;5.1;IFCAP;**147**;Oct 20, 2000;Build 3
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;;
  1. ;PRC*147 saving 410 link in 442 order record being archived to correctly handle 1358 doc print given error conditions from too many DA passed parameters in previous copy
  1. DOC(DA) ;completely archive 1 purchase order
  1. QUIT:$P($G(^PRC(442,DA,0)),"^",1)=""
  1. NEW VENDOR,X,XDA,IEN410 S X=$P($G(^PRC(442,DA,1)),"^") I X S VENDOR=$P($G(^PRC(440,+X,0)),"^")
  1. W "~~PRCG~~^",!,$P(^PRC(442,DA,0),"^",1)_"^"_$G(VENDOR)
  1. S ZNODE=$G(^PRC(442,DA,0)) Q:ZNODE=""
  1. S IEN410=$P($G(^PRC(442,DA,0)),"^",12) ;PRC*147 saving 410 linked to archived 442 ien for document printing
  1. S MOP=$P(ZNODE,"^",2)
  1. I MOP<1 S MOP="NULL" G DOIT
  1. S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
  1. I MOP="" S MOP="NULL"
  1. S XDA=DA ;PRC*147 saving archive 442 ien
  1. DOIT U MTIO S IO=MTIO D @MOP S IO=DEVIO
  1. QUIT
  1. CI ;certified invoice
  1. PIA ;payment in advance
  1. DD ;guaranteed delivery
  1. ST ;invoice/receiving report
  1. IF ;imprest fund
  1. RQ ;requisition
  1. PC ;purchase card
  1. AB ;autobank
  1. AR ;accounts receivable
  1. NULL D PO(DA)
  1. D ALLRR(DA)
  1. D ALL410
  1. QUIT
  1. 1358 ;misc obligation
  1. I +IEN410,$D(^PRCS(410,+IEN410,0)) D ALL410
  1. Q
  1. IS ;issue
  1. TA ;travel authority
  1. OTA ;open travel authority
  1. QUIT
  1. PO(DA) ;archive one purchase order
  1. S D0=DA D ^PRCHFPNT
  1. QUIT
  1. ALLRR(DA) ;archive all receiving reports for a PO (DA)
  1. NEW RRNUM
  1. S RRNUM=""
  1. F S RRNUM=$O(^PRC(442,DA,11,RRNUM)) Q:'RRNUM I RRNUM>0 S D0=DA,PRCHFPT=RRNUM D ^PRCHFPNT
  1. QUIT
  1. ALL410 ;archive all 410 documents related to PO (DA)
  1. NEW N,DA410,X,PRIMARY
  1. ;primary
  1. S PRIMARY=+IEN410 I $D(^PRCS(410,+IEN410,0)) D 410(IEN410)
  1. ;any other 2237s on PO
  1. S N=""
  1. F S N=$O(^PRC(442,DA,13,N)) Q:'N S DA410=$P($G(^(N,0)),"^") I DA410,$D(^PRCS(410,DA410,0)),DA410'=PRIMARY D 410(DA410)
  1. QUIT
  1. 410(DA) ;archive 1 410 record
  1. Q:+DA=0
  1. N TRNODE,X2237 S X2237=$P($G(^PRCS(410,DA,0)),"^",4)
  1. I X2237=1 S TRNODE(0)="" D NODE^PRCS58OB(DA,.TRNODE),^PRCE58P2
  1. D:X2237=5 DQ^PRCPRIB0 D:(X2237'=1)&(X2237'=5) ^PRCSP12
  1. QUIT
  1. ERR ;go here when tape error
  1. QUIT X ^%ZOSF("MTERR") I 'Y S %ZTERLGR=OLDET D ^%ZTER
  1. U MTIO W @%MT("BS") D G V
  1. . U MTIO R X:10 Q:'$T
  1. . I X["DAV/VHA IFCAP ARCHIVE" D
  1. . . W @%MT("BS"),@%MT("WEL"),%MT("REW")
  1. . . F D G:X["^" END X ^%ZOSF("MTONLINE") Q:Y=1
  1. . . . U IO(0) R !!,"Please load new tape and press <CR> to continue",X:1200
  1. . . . QUIT
  1. . . U MTIO W @%MT("BS"),@%MT("BS")
  1. . . QUIT
  1. ;
  1. END ;