- PRCGARCG ;WIRMFO@ALTOONA/CTB/BGJ IFCAP ARCHIVE FIND ROUTINE ;12/10/97 9:07 AM [8/17/98 9:01am]
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- I CLEANFIL=1 D
- . S X="But First - I will delete all current entries in the IFCAP Pending Archive file for Station - "_PRC("SITE")
- . D MSG^PRCFQ
- . D ^PRCGARCH
- . R X:5 W @IOF
- . QUIT
- I $D(UPOUT) K UPOUT D END^PRCGU,END QUIT
- D WAIT^PRCFYN
- S EFY=$E(FY,1,3)_"0930"
- S BFY=$E(FY,1,3)-1_"1001"
- S NX=0 F I=0:1 S NX=$O(^PRC(442,"AB",NX)) Q:(NX>FY)!(NX="")
- I I=0 S X="There are no records on file for FY "_AFY_" or earlier. No action taken.*" D MSG^PRCFQ QUIT
- S TREC=I,RECCOUNT=0
- S MESSAGE="FINDING IFCAP RECORDS FOR ARCHIVE/PURGE"
- S ITEMS="days"
- D BEGIN^PRCGU
- S NX=0 D PERCENT^PRCGU
- F XCOUNT=1:1 S NX=$O(^PRC(442,"AB",NX)) Q:(NX>FY)!(NX="")!($D(UPOUT)) D D:'$D(ZTQUEUED) PERCENT^PRCGU
- . 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
- . . S ZERONODE=$G(^PRC(442,MX,0))
- . . I $P(ZERONODE,"-")'=PRC("SITE") QUIT
- . . S FLAG=$$CHECK(MX,ZERONODE) QUIT:'FLAG
- . . S X=$P(ZERONODE,"^",1)
- . . D ADD(MX,X,FLAG) Q:Y<0 S RECCOUNT=RECCOUNT+1
- . . QUIT
- . QUIT
- I $D(UPOUT) D END^PRCGU,END K UPOUT QUIT
- D END^PRCGU
- W !!,RECCOUNT," documents were found and added to the IFCAP Pending Archive File."
- 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
- 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
- QUIT
- ADD(DA,X,FLAG) ;add record to 443.9
- NEW MOP,Z
- S MOP=$P(FLAG,"^",2),FLAG=$P(FLAG,"^")
- L +^PRC(443.9):5 I '$T S Y=-1 Q
- S:'$D(^PRC(443.9,DA)) Y=$P(^PRC(443.9,0),"^",4),Y=Y+1,$P(^(0),"^",3,4)=DA_"^"_Y
- S ^PRC(443.9,DA,0)=DA_"^"_FLAG_"^"_MOP_"^"_X,^PRC(443.9,"B",DA,DA)="",^PRC(443.9,"AC",X,DA)=""
- L -^PRC(443.9)
- S Y=DA QUIT
- CHECK(DA,ZNODE) ;;BEGIN CHECK ARCHIVE CRITERON?
- N MOP,ARCBIT
- S MOP=$P(ZNODE,"^",2)
- I 'MOP QUIT 2
- I MOP=5!(MOP=6) D
- . S $P(^PRC(442,DA,0),U,2)=1
- . S MOP=1
- . QUIT
- S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
- I MOP="" Q 2
- S ARCBIT="" D @MOP QUIT ARCBIT_"^"_MOP
- IS ;;ISSUES
- TA ;;TRAVEL
- OTA ;;OPEN TRAVEL
- QUIT
- AR ;;ACCOUNTS RECEIVABLE
- S ARCBIT=3
- QUIT
- CI ;;CERTIFIED INVOICE
- PIA ;;PAYMENT IN ADVANCE
- DD ;;GUARANTEED DELIVERY
- NEW SS,FS
- S SS=+$G(^PRC(442,DA,7))
- I 'SS S ARCBIT=2 QUIT
- S FS=$P($G(^PRCD(442.3,SS,0)),"^",3)
- S:FS>10 ARCBIT=1 I ((SS<11)!(SS>34)) S ARCBIT=$G(ARCBIT)+2
- QUIT
- 1358 ;;1358
- NEW SS,FS
- S SS=+$G(^PRC(442,DA,7))
- I 'SS S ARCBIT=2 QUIT
- S FS=$P($G(^PRCD(442.3,SS,0)),"^",3)
- S:FS>10 ARCBIT=1 I ((FS<11)!((FS>34)&(FS'=100))) S ARCBIT=$G(ARCBIT)+2
- QUIT
- ST ;;INVOICE/RECEIVING REPORT
- IF ;;IMPREST FUND/CASHIER
- RQ ;;REQUISITION
- PC ;;PURCHASE CARD
- AB ;;AUTOBANK
- S SS=+$G(^PRC(442,DA,7))
- I 'SS S ARCBIT=2 QUIT
- S SS=$P($G(^PRCD(442.3,SS,0)),"^",2)
- S:SS>10 ARCBIT=1 I ((SS<11)!(SS>29)) S ARCBIT=$G(ARCBIT)+2
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGARCG 3212 printed Jan 18, 2025@03:05:58 Page 2
- PRCGARCG ;WIRMFO@ALTOONA/CTB/BGJ IFCAP ARCHIVE FIND ROUTINE ;12/10/97 9:07 AM [8/17/98 9:01am]
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 WRITE @IOF
- SET X="I will now begin compiling a list of archive documents for this process from file 442 for FY "_AFY_" and earlier."
- DO MSG^PRCFQ
- +3 IF CLEANFIL=1
- Begin DoDot:1
- +4 SET X="But First - I will delete all current entries in the IFCAP Pending Archive file for Station - "_PRC("SITE")
- +5 DO MSG^PRCFQ
- +6 DO ^PRCGARCH
- +7 READ X:5
- WRITE @IOF
- +8 QUIT
- End DoDot:1
- +9 IF $DATA(UPOUT)
- KILL UPOUT
- DO END^PRCGU
- DO END
- QUIT
- +10 DO WAIT^PRCFYN
- +11 SET EFY=$EXTRACT(FY,1,3)_"0930"
- +12 SET BFY=$EXTRACT(FY,1,3)-1_"1001"
- +13 SET NX=0
- FOR I=0:1
- SET NX=$ORDER(^PRC(442,"AB",NX))
- if (NX>FY)!(NX="")
- QUIT
- +14 IF I=0
- SET X="There are no records on file for FY "_AFY_" or earlier. No action taken.*"
- DO MSG^PRCFQ
- QUIT
- +15 SET TREC=I
- SET RECCOUNT=0
- +16 SET MESSAGE="FINDING IFCAP RECORDS FOR ARCHIVE/PURGE"
- +17 SET ITEMS="days"
- +18 DO BEGIN^PRCGU
- +19 SET NX=0
- DO PERCENT^PRCGU
- +20 FOR XCOUNT=1:1
- SET NX=$ORDER(^PRC(442,"AB",NX))
- if (NX>FY)!(NX="")!($DATA(UPOUT))
- QUIT
- Begin DoDot:1
- +21 SET MX=0
- FOR
- SET MX=$ORDER(^PRC(442,"AB",NX,MX))
- if 'MX
- QUIT
- Begin DoDot:2
- +22 SET ZERONODE=$GET(^PRC(442,MX,0))
- +23 IF $PIECE(ZERONODE,"-")'=PRC("SITE")
- QUIT
- +24 SET FLAG=$$CHECK(MX,ZERONODE)
- if 'FLAG
- QUIT
- +25 SET X=$PIECE(ZERONODE,"^",1)
- +26 DO ADD(MX,X,FLAG)
- if Y<0
- QUIT
- SET RECCOUNT=RECCOUNT+1
- +27 QUIT
- End DoDot:2
- READ X:0
- IF X["^"
- WRITE !!!,"Option Terminated.",*7
- SET UPOUT=""
- QUIT
- +28 QUIT
- End DoDot:1
- if '$DATA(ZTQUEUED)
- DO PERCENT^PRCGU
- +29 IF $DATA(UPOUT)
- DO END^PRCGU
- DO END
- KILL UPOUT
- QUIT
- +30 DO END^PRCGU
- +31 WRITE !!,RECCOUNT," documents were found and added to the IFCAP Pending Archive File."
- END KILL 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 KILL %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
- +2 QUIT
- ADD(DA,X,FLAG) ;add record to 443.9
- +1 NEW MOP,Z
- +2 SET MOP=$PIECE(FLAG,"^",2)
- SET FLAG=$PIECE(FLAG,"^")
- +3 LOCK +^PRC(443.9):5
- IF '$TEST
- SET Y=-1
- QUIT
- +4 if '$DATA(^PRC(443.9,DA))
- SET Y=$PIECE(^PRC(443.9,0),"^",4)
- SET Y=Y+1
- SET $PIECE(^(0),"^",3,4)=DA_"^"_Y
- +5 SET ^PRC(443.9,DA,0)=DA_"^"_FLAG_"^"_MOP_"^"_X
- SET ^PRC(443.9,"B",DA,DA)=""
- SET ^PRC(443.9,"AC",X,DA)=""
- +6 LOCK -^PRC(443.9)
- +7 SET Y=DA
- QUIT
- CHECK(DA,ZNODE) ;;BEGIN CHECK ARCHIVE CRITERON?
- +1 NEW MOP,ARCBIT
- +2 SET MOP=$PIECE(ZNODE,"^",2)
- +3 IF 'MOP
- QUIT 2
- +4 IF MOP=5!(MOP=6)
- Begin DoDot:1
- +5 SET $PIECE(^PRC(442,DA,0),U,2)=1
- +6 SET MOP=1
- +7 QUIT
- End DoDot:1
- +8 SET MOP=$PIECE($GET(^PRCD(442.5,MOP,0)),"^",2)
- +9 IF MOP=""
- QUIT 2
- +10 SET ARCBIT=""
- DO @MOP
- QUIT ARCBIT_"^"_MOP
- IS ;;ISSUES
- TA ;;TRAVEL
- OTA ;;OPEN TRAVEL
- +1 QUIT
- AR ;;ACCOUNTS RECEIVABLE
- +1 SET ARCBIT=3
- +2 QUIT
- CI ;;CERTIFIED INVOICE
- PIA ;;PAYMENT IN ADVANCE
- DD ;;GUARANTEED DELIVERY
- +1 NEW SS,FS
- +2 SET SS=+$GET(^PRC(442,DA,7))
- +3 IF 'SS
- SET ARCBIT=2
- QUIT
- +4 SET FS=$PIECE($GET(^PRCD(442.3,SS,0)),"^",3)
- +5 if FS>10
- SET ARCBIT=1
- IF ((SS<11)!(SS>34))
- SET ARCBIT=$GET(ARCBIT)+2
- +6 QUIT
- 1358 ;;1358
- +1 NEW SS,FS
- +2 SET SS=+$GET(^PRC(442,DA,7))
- +3 IF 'SS
- SET ARCBIT=2
- QUIT
- +4 SET FS=$PIECE($GET(^PRCD(442.3,SS,0)),"^",3)
- +5 if FS>10
- SET ARCBIT=1
- IF ((FS<11)!((FS>34)&(FS'=100)))
- SET ARCBIT=$GET(ARCBIT)+2
- +6 QUIT
- ST ;;INVOICE/RECEIVING REPORT
- IF ;;IMPREST FUND/CASHIER
- RQ ;;REQUISITION
- PC ;;PURCHASE CARD
- AB ;;AUTOBANK
- +1 SET SS=+$GET(^PRC(442,DA,7))
- +2 IF 'SS
- SET ARCBIT=2
- QUIT
- +3 SET SS=$PIECE($GET(^PRCD(442.3,SS,0)),"^",2)
- +4 if SS>10
- SET ARCBIT=1
- IF ((SS<11)!(SS>29))
- SET ARCBIT=$GET(ARCBIT)+2
- +5 QUIT