| [613] | 1 | PRCGARC1 ;WIRMFO@ALTOONA/CTB/BGJ - IFCAP ARCHIVE SUBROUTINES ;12/10/97 9:04 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;;
|
|---|
| 5 | DOC(DA) ;completely archive 1 purchase order
|
|---|
| 6 | QUIT:$P($G(^PRC(442,DA,0)),"^",1)=""
|
|---|
| 7 | NEW VENDOR,X S X=$P($G(^PRC(442,DA,1)),"^") I X S VENDOR=$P($G(^PRC(440,+X,0)),"^")
|
|---|
| 8 | W "~~PRCG~~^",!,$P(^PRC(442,DA,0),"^",1)_"^"_$G(VENDOR)
|
|---|
| 9 | S ZNODE=$G(^PRC(442,DA,0)) Q:ZNODE=""
|
|---|
| 10 | S MOP=$P(ZNODE,"^",2)
|
|---|
| 11 | I MOP<1 S MOP="NULL" G DOIT
|
|---|
| 12 | S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
|
|---|
| 13 | I MOP="" S MOP="NULL"
|
|---|
| 14 | DOIT U MTIO S IO=MTIO D @MOP S IO=DEVIO
|
|---|
| 15 | QUIT
|
|---|
| 16 | CI ;certified invoice
|
|---|
| 17 | PIA ;payment in advance
|
|---|
| 18 | DD ;guaranteed delivery
|
|---|
| 19 | ST ;invoice/receiving report
|
|---|
| 20 | IF ;imprest fund
|
|---|
| 21 | RQ ;requisition
|
|---|
| 22 | PC ;purchase card
|
|---|
| 23 | AB ;autobank
|
|---|
| 24 | AR ;accounts receivable
|
|---|
| 25 | NULL D PO(DA)
|
|---|
| 26 | D ALLRR(DA)
|
|---|
| 27 | D ALL410(DA)
|
|---|
| 28 | QUIT
|
|---|
| 29 | 1358 ;misc obligation
|
|---|
| 30 | S X=$P($G(^PRC(442,DA,0)),"^",12) I +X,$D(^PRCS(410,+X,0)) D ALL410(X)
|
|---|
| 31 | Q
|
|---|
| 32 | IS ;issue
|
|---|
| 33 | TA ;travel authority
|
|---|
| 34 | OTA ;open travel authority
|
|---|
| 35 | QUIT
|
|---|
| 36 | PO(DA) ;archive one purchase order
|
|---|
| 37 | S D0=DA D ^PRCHFPNT
|
|---|
| 38 | QUIT
|
|---|
| 39 | ALLRR(DA) ;archive all receiving reports for a PO (DA)
|
|---|
| 40 | NEW RRNUM
|
|---|
| 41 | S RRNUM=""
|
|---|
| 42 | F S RRNUM=$O(^PRC(442,DA,11,RRNUM)) Q:'RRNUM I RRNUM>0 S D0=DA,PRCHFPT=RRNUM D ^PRCHFPNT
|
|---|
| 43 | QUIT
|
|---|
| 44 | ALL410(DA) ;archive all 410 documents related to PO (DA)
|
|---|
| 45 | NEW N,DA410,X,PRIMARY
|
|---|
| 46 | ;primary
|
|---|
| 47 | S X=$P($G(^PRC(442,DA,0)),"^",12) I +X,$D(^PRCS(410,+X,0)) S PRIMARY=+X D 410(X)
|
|---|
| 48 | ;any other 2237s on PO
|
|---|
| 49 | S N=""
|
|---|
| 50 | 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)
|
|---|
| 51 | QUIT
|
|---|
| 52 | 410(DA) ;archive 1 410 record
|
|---|
| 53 | N TRNODE,X2237 S X2237=$P($G(^PRCS(410,DA,0)),"^",4)
|
|---|
| 54 | I X2237=1 S TRNODE(0)="" D NODE^PRCS58OB(DA,.TRNODE),^PRCE58P2
|
|---|
| 55 | D:X2237=5 DQ^PRCPRIB0 D:(X2237'=1)&(X2237'=5) ^PRCSP12
|
|---|
| 56 | QUIT
|
|---|
| 57 | ERR ;go here when tape error
|
|---|
| 58 | QUIT X ^%ZOSF("MTERR") I 'Y S %ZTERLGR=OLDET D ^%ZTER
|
|---|
| 59 | U MTIO W @%MT("BS") D G V
|
|---|
| 60 | . U MTIO R X:10 Q:'$T
|
|---|
| 61 | . I X["DAV/VHA IFCAP ARCHIVE" D
|
|---|
| 62 | . . W @%MT("BS"),@%MT("WEL"),%MT("REW")
|
|---|
| 63 | . . F D G:X["^" END X ^%ZOSF("MTONLINE") Q:Y=1
|
|---|
| 64 | . . . U IO(0) R !!,"Please load new tape and press <CR> to continue",X:1200
|
|---|
| 65 | . . . QUIT
|
|---|
| 66 | . . U MTIO W @%MT("BS"),@%MT("BS")
|
|---|
| 67 | . . QUIT
|
|---|
| 68 | ;
|
|---|
| 69 | END ;
|
|---|
