source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGARC1.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1PRCGARC1 ;WIRMFO@ALTOONA/CTB/BGJ - IFCAP ARCHIVE SUBROUTINES ;12/10/97 9:04 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;;
5DOC(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"
14DOIT U MTIO S IO=MTIO D @MOP S IO=DEVIO
15 QUIT
16CI ;certified invoice
17PIA ;payment in advance
18DD ;guaranteed delivery
19ST ;invoice/receiving report
20IF ;imprest fund
21RQ ;requisition
22PC ;purchase card
23AB ;autobank
24AR ;accounts receivable
25NULL D PO(DA)
26 D ALLRR(DA)
27 D ALL410(DA)
28 QUIT
291358 ;misc obligation
30 S X=$P($G(^PRC(442,DA,0)),"^",12) I +X,$D(^PRCS(410,+X,0)) D ALL410(X)
31 Q
32IS ;issue
33TA ;travel authority
34OTA ;open travel authority
35 QUIT
36PO(DA) ;archive one purchase order
37 S D0=DA D ^PRCHFPNT
38 QUIT
39ALLRR(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
44ALL410(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
52410(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
57ERR ;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 ;
69END ;
Note: See TracBrowser for help on using the repository browser.