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

PRCGARCG.m

Go to the documentation of this file.
  1. PRCGARCG ;WIRMFO@ALTOONA/CTB/BGJ IFCAP ARCHIVE FIND ROUTINE ;12/10/97 9:07 AM [8/17/98 9:01am]
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 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
  1. I CLEANFIL=1 D
  1. . S X="But First - I will delete all current entries in the IFCAP Pending Archive file for Station - "_PRC("SITE")
  1. . D MSG^PRCFQ
  1. . D ^PRCGARCH
  1. . R X:5 W @IOF
  1. . QUIT
  1. I $D(UPOUT) K UPOUT D END^PRCGU,END QUIT
  1. D WAIT^PRCFYN
  1. S EFY=$E(FY,1,3)_"0930"
  1. S BFY=$E(FY,1,3)-1_"1001"
  1. S NX=0 F I=0:1 S NX=$O(^PRC(442,"AB",NX)) Q:(NX>FY)!(NX="")
  1. I I=0 S X="There are no records on file for FY "_AFY_" or earlier. No action taken.*" D MSG^PRCFQ QUIT
  1. S TREC=I,RECCOUNT=0
  1. S MESSAGE="FINDING IFCAP RECORDS FOR ARCHIVE/PURGE"
  1. S ITEMS="days"
  1. D BEGIN^PRCGU
  1. S NX=0 D PERCENT^PRCGU
  1. F XCOUNT=1:1 S NX=$O(^PRC(442,"AB",NX)) Q:(NX>FY)!(NX="")!($D(UPOUT)) D D:'$D(ZTQUEUED) PERCENT^PRCGU
  1. . 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
  1. . . S ZERONODE=$G(^PRC(442,MX,0))
  1. . . I $P(ZERONODE,"-")'=PRC("SITE") QUIT
  1. . . S FLAG=$$CHECK(MX,ZERONODE) QUIT:'FLAG
  1. . . S X=$P(ZERONODE,"^",1)
  1. . . D ADD(MX,X,FLAG) Q:Y<0 S RECCOUNT=RECCOUNT+1
  1. . . QUIT
  1. . QUIT
  1. I $D(UPOUT) D END^PRCGU,END K UPOUT QUIT
  1. D END^PRCGU
  1. W !!,RECCOUNT," documents were found and added to the IFCAP Pending Archive File."
  1. END 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
  1. 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
  1. QUIT
  1. ADD(DA,X,FLAG) ;add record to 443.9
  1. NEW MOP,Z
  1. S MOP=$P(FLAG,"^",2),FLAG=$P(FLAG,"^")
  1. L +^PRC(443.9):5 I '$T S Y=-1 Q
  1. S:'$D(^PRC(443.9,DA)) Y=$P(^PRC(443.9,0),"^",4),Y=Y+1,$P(^(0),"^",3,4)=DA_"^"_Y
  1. S ^PRC(443.9,DA,0)=DA_"^"_FLAG_"^"_MOP_"^"_X,^PRC(443.9,"B",DA,DA)="",^PRC(443.9,"AC",X,DA)=""
  1. L -^PRC(443.9)
  1. S Y=DA QUIT
  1. CHECK(DA,ZNODE) ;;BEGIN CHECK ARCHIVE CRITERON?
  1. N MOP,ARCBIT
  1. S MOP=$P(ZNODE,"^",2)
  1. I 'MOP QUIT 2
  1. I MOP=5!(MOP=6) D
  1. . S $P(^PRC(442,DA,0),U,2)=1
  1. . S MOP=1
  1. . QUIT
  1. S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
  1. I MOP="" Q 2
  1. S ARCBIT="" D @MOP QUIT ARCBIT_"^"_MOP
  1. IS ;;ISSUES
  1. TA ;;TRAVEL
  1. OTA ;;OPEN TRAVEL
  1. QUIT
  1. AR ;;ACCOUNTS RECEIVABLE
  1. S ARCBIT=3
  1. QUIT
  1. CI ;;CERTIFIED INVOICE
  1. PIA ;;PAYMENT IN ADVANCE
  1. DD ;;GUARANTEED DELIVERY
  1. NEW SS,FS
  1. S SS=+$G(^PRC(442,DA,7))
  1. I 'SS S ARCBIT=2 QUIT
  1. S FS=$P($G(^PRCD(442.3,SS,0)),"^",3)
  1. S:FS>10 ARCBIT=1 I ((SS<11)!(SS>34)) S ARCBIT=$G(ARCBIT)+2
  1. QUIT
  1. 1358 ;;1358
  1. NEW SS,FS
  1. S SS=+$G(^PRC(442,DA,7))
  1. I 'SS S ARCBIT=2 QUIT
  1. S FS=$P($G(^PRCD(442.3,SS,0)),"^",3)
  1. S:FS>10 ARCBIT=1 I ((FS<11)!((FS>34)&(FS'=100))) S ARCBIT=$G(ARCBIT)+2
  1. QUIT
  1. ST ;;INVOICE/RECEIVING REPORT
  1. IF ;;IMPREST FUND/CASHIER
  1. RQ ;;REQUISITION
  1. PC ;;PURCHASE CARD
  1. AB ;;AUTOBANK
  1. S SS=+$G(^PRC(442,DA,7))
  1. I 'SS S ARCBIT=2 QUIT
  1. S SS=$P($G(^PRCD(442.3,SS,0)),"^",2)
  1. S:SS>10 ARCBIT=1 I ((SS<11)!(SS>29)) S ARCBIT=$G(ARCBIT)+2
  1. QUIT