source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGARCG.m@ 613

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1PRCGARCG ;WIRMFO@ALTOONA/CTB/BGJ IFCAP ARCHIVE FIND ROUTINE ;12/10/97 9:07 AM [8/17/98 9:01am]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 W @IOF S X="I will now begin compiling a list of archive documents for this process from file 442 for FY "_AFY_" and earlier." D MSG^PRCFQ
5 I CLEANFIL=1 D
6 . S X="But First - I will delete all current entries in the IFCAP Pending Archive file for Station - "_PRC("SITE")
7 . D MSG^PRCFQ
8 . D ^PRCGARCH
9 . R X:5 W @IOF
10 . QUIT
11 I $D(UPOUT) K UPOUT D END^PRCGU,END QUIT
12 D WAIT^PRCFYN
13 S EFY=$E(FY,1,3)_"0930"
14 S BFY=$E(FY,1,3)-1_"1001"
15 S NX=0 F I=0:1 S NX=$O(^PRC(442,"AB",NX)) Q:(NX>FY)!(NX="")
16 I I=0 S X="There are no records on file for FY "_AFY_" or earlier. No action taken.*" D MSG^PRCFQ QUIT
17 S TREC=I,RECCOUNT=0
18 S MESSAGE="FINDING IFCAP RECORDS FOR ARCHIVE/PURGE"
19 S ITEMS="days"
20 D BEGIN^PRCGU
21 S NX=0 D PERCENT^PRCGU
22 F XCOUNT=1:1 S NX=$O(^PRC(442,"AB",NX)) Q:(NX>FY)!(NX="")!($D(UPOUT)) D D:'$D(ZTQUEUED) PERCENT^PRCGU
23 . S MX=0 F S MX=$O(^PRC(442,"AB",NX,MX)) Q:'MX D R X:0 I X["^" W !!!,"Option Terminated.",*7 S UPOUT="" QUIT
24 . . S ZERONODE=$G(^PRC(442,MX,0))
25 . . I $P(ZERONODE,"-")'=PRC("SITE") QUIT
26 . . S FLAG=$$CHECK(MX,ZERONODE) QUIT:'FLAG
27 . . S X=$P(ZERONODE,"^",1)
28 . . D ADD(MX,X,FLAG) Q:Y<0 S RECCOUNT=RECCOUNT+1
29 . . QUIT
30 . QUIT
31 I $D(UPOUT) D END^PRCGU,END K UPOUT QUIT
32 D END^PRCGU
33 W !!,RECCOUNT," documents were found and added to the IFCAP Pending Archive File."
34END K FY,BFY,EFY,CFY,AFY,NX,MX,ZERONODE,FLAG,X,Y,TREC,CREC,LREC,XPOS,DX,CY,MOP,ARCBIT,DIC,DLAYGO,A,N,M,PERCENT,RECCOUNT
35 K %DT,ARCHECK,CURSOR,CLEANFIL,D0,DG,DICR,DIG,DIH,DIU,DIV,DIW,ITEMS,MESSAGE,OUT,RTIME,TTIME,YPOS,BTIME,DA,LASTENT,LINE,SS,TIME,XCOUNT
36 QUIT
37ADD(DA,X,FLAG) ;add record to 443.9
38 NEW MOP,Z
39 S MOP=$P(FLAG,"^",2),FLAG=$P(FLAG,"^")
40 L +^PRC(443.9):5 I '$T S Y=-1 Q
41 S:'$D(^PRC(443.9,DA)) Y=$P(^PRC(443.9,0),"^",4),Y=Y+1,$P(^(0),"^",3,4)=DA_"^"_Y
42 S ^PRC(443.9,DA,0)=DA_"^"_FLAG_"^"_MOP_"^"_X,^PRC(443.9,"B",DA,DA)="",^PRC(443.9,"AC",X,DA)=""
43 L -^PRC(443.9)
44 S Y=DA QUIT
45CHECK(DA,ZNODE) ;;BEGIN CHECK ARCHIVE CRITERON?
46 N MOP,ARCBIT
47 S MOP=$P(ZNODE,"^",2)
48 I 'MOP QUIT 2
49 I MOP=5!(MOP=6) D
50 . S $P(^PRC(442,DA,0),U,2)=1
51 . S MOP=1
52 . QUIT
53 S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
54 I MOP="" Q 2
55 S ARCBIT="" D @MOP QUIT ARCBIT_"^"_MOP
56IS ;;ISSUES
57TA ;;TRAVEL
58OTA ;;OPEN TRAVEL
59 QUIT
60AR ;;ACCOUNTS RECEIVABLE
61 S ARCBIT=3
62 QUIT
63CI ;;CERTIFIED INVOICE
64PIA ;;PAYMENT IN ADVANCE
65DD ;;GUARANTEED DELIVERY
66 NEW SS,FS
67 S SS=+$G(^PRC(442,DA,7))
68 I 'SS S ARCBIT=2 QUIT
69 S FS=$P($G(^PRCD(442.3,SS,0)),"^",3)
70 S:FS>10 ARCBIT=1 I ((SS<11)!(SS>34)) S ARCBIT=$G(ARCBIT)+2
71 QUIT
721358 ;;1358
73 NEW SS,FS
74 S SS=+$G(^PRC(442,DA,7))
75 I 'SS S ARCBIT=2 QUIT
76 S FS=$P($G(^PRCD(442.3,SS,0)),"^",3)
77 S:FS>10 ARCBIT=1 I ((FS<11)!((FS>34)&(FS'=100))) S ARCBIT=$G(ARCBIT)+2
78 QUIT
79ST ;;INVOICE/RECEIVING REPORT
80IF ;;IMPREST FUND/CASHIER
81RQ ;;REQUISITION
82PC ;;PURCHASE CARD
83AB ;;AUTOBANK
84 S SS=+$G(^PRC(442,DA,7))
85 I 'SS S ARCBIT=2 QUIT
86 S SS=$P($G(^PRCD(442.3,SS,0)),"^",2)
87 S:SS>10 ARCBIT=1 I ((SS<11)!(SS>29)) S ARCBIT=$G(ARCBIT)+2
88 QUIT
Note: See TracBrowser for help on using the repository browser.