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

PRCGARP1.m

Go to the documentation of this file.
  1. PRCGARP1 ;WIRMFO/CTB/BGJ-IFCAP PURGEMASTER ROUTINE FOR FILE 442 ;12/10/97 9:07 AM
  1. V ;;5.1;IFCAP;**46,131,150**;Oct 20, 2000;Build 24
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
  1. ;kill (DIK) since DIK call does not handle descending file logic
  1. START(X) ;
  1. NEW BEGDA,ENDA,SITE,DIK,DA,MOP,ZNODE
  1. S BEGDA=$P(X,"-",1),ENDA=+$P(X,"-",2),SITE=$P(X,";",2)
  1. S DA=BEGDA-1
  1. F S DA=$O(^PRC(443.9,DA)) Q:'DA!(DA>ENDA) D
  1. . S ZNODE=$G(^PRC(443.9,DA,0)) Q:ZNODE=""
  1. . I +$P(ZNODE,"^",4)'=SITE QUIT
  1. . I $P(ZNODE,"^",2)=1 D REMOVE^PRCGARCH QUIT
  1. . S MOP=$P(ZNODE,"^",3)
  1. . S:MOP="" MOP="NULL"
  1. . D @MOP
  1. . D REMOVE^PRCGARCH
  1. . QUIT
  1. QUIT
  1. IS ;;ISSUES
  1. TA ;;TRAVEL
  1. OTA ;;OPEN TRAVEL
  1. ;;enter code here to completely delete one entry in 442 of the types
  1. ;; listed above.
  1. QUIT
  1. AR ;;ACCOUNTS RECEIVABLE
  1. N PRCHDA
  1. QUIT:'$D(DA)
  1. S PRCHDA=DA
  1. Q:'$D(^PRC(442,PRCHDA,0))
  1. D KILL442(PRCHDA)
  1. QUIT
  1. NULL ;;442 entry with no MOP
  1. CI ;;CERTIFIED INVOICE
  1. PIA ;;PAYMENT IN ADVANCE
  1. DD ;;GUARANTEED DELIVERY
  1. ST ;;INVOICE/RECEIVING REPORT
  1. IF ;;IMPREST FUND/CASHIER
  1. PC ;;PURCHASE CARD
  1. AB ;;AUTOBANK
  1. RQ ;;REQUISITION
  1. N PRCHDA,PRCHFY,FY,X,I
  1. QUIT:'$D(DA)
  1. S PRCHDA=DA
  1. Q:'$D(^PRC(442,PRCHDA,0))
  1. D K2237(PRCHDA)
  1. D K4215(PRCHDA)
  1. ;delete file 441,442.9 entries
  1. D K4429(PRCHDA)
  1. D P441^PRCGPPC1(PRCHDA)
  1. ;finally, delete 442 and 443.6 (amendments file)
  1. D KILL442(PRCHDA)
  1. D KILL4436(PRCHDA)
  1. ;
  1. QUIT
  1. 1358 ;;1358
  1. ;;enter code here to completely delete one 1358
  1. ;delete 410 files, 421.5, 441, 442 files, and finally 442
  1. N PRCHDA,X
  1. QUIT:'$D(DA)
  1. S PRCHDA=DA
  1. Q:'$D(^PRC(442,PRCHDA,0))
  1. D K2237(PRCHDA)
  1. ;delete 1358
  1. D:$D(^PRC(424,"C",PRCHDA)) DL424^PRCGPPC1(PRCHDA)
  1. D K4215(PRCHDA)
  1. D K4429(PRCHDA)
  1. D KLL4406(PRCHDA),KLL4219(PRCHDA)
  1. ;finally, delete 442
  1. D KILL442(PRCHDA)
  1. QUIT
  1. K4215(PRCHDA) ;
  1. NEW PRCFDA
  1. S PRCFDA=0 F S PRCFDA=$O(^PRCF(421.5,"E",PRCHDA,PRCFDA)) Q:PRCFDA="" D KILL4215(PRCFDA)
  1. QUIT
  1. KILL410(DA) ;
  1. Q:'$D(^PRCS(410,DA,0))
  1. S PRCIENCT=$P(^PRCS(410,0),"^",3) ;PRC*5.1*150
  1. S DIK="^PRCS(410," D ^DIK
  1. S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150
  1. K DIK
  1. QUIT
  1. KILL443(DA) ;
  1. Q:'$D(^PRC(443,DA,0))
  1. S DIK="^PRC(443," D ^DIK
  1. K DIK
  1. QUIT
  1. KILL4215(DA) ;
  1. S DIK="^PRCF(421.5," D ^DIK
  1. K DIK
  1. QUIT
  1. KILL442(DA) ;
  1. D KILL4101(DA)
  1. D KLL4406(DA),KLL4219(DA)
  1. S DIK="^PRC(442," D ^DIK
  1. K DIK
  1. QUIT
  1. KILL4101(X) ;Delete 410.1 record when entry in 442 is deleted
  1. ;
  1. N DA
  1. S X=$P($G(^PRC(442,X,0)),"^")
  1. Q:X'>0
  1. S DIC(0)="X"
  1. S DIC="^PRCS(410.1,"
  1. D ^DIC
  1. Q:Y=-1
  1. S DA=+Y
  1. S DIK="^PRCS(410.1," D ^DIK
  1. K DIC,DIK,X,Y
  1. QUIT
  1. ;
  1. KILL4436(DA) ;
  1. S DIK="^PRC(443.6," D ^DIK
  1. K DIK
  1. QUIT
  1. K2237(PRCHDA) ;kill primary 2237
  1. N PRCSDA
  1. S PRCSDA=$P($G(^PRC(442,PRCHDA,0)),"^",12)
  1. I +PRCSDA,$D(^PRCS(410,+PRCSDA)) D KILL410(PRCSDA)
  1. ;kill other 2237's if present
  1. I $D(^PRC(442,PRCHDA,13)) D
  1. .F I=1:1:20 S PRCSDA=$O(^PRC(442,PRCHDA,13,0)) Q:PRCSDA="" D
  1. . . I $D(^PRCS(410,PRCSDA,0)) D KILL410(PRCSDA)
  1. . . I $D(^PRC(443,PRCSDA,0)) D KILL443(PRCSDA)
  1. . . QUIT
  1. . QUIT
  1. QUIT
  1. K4429(PRCHDA) ;
  1. N EXPONUM
  1. S EXPONUM=$P($G(^PRC(442.9,PRCHDA,0)),"^",4) D:EXPONUM'="" P4429^PRCGPPC1(EXPONUM)
  1. QUIT
  1. KLL4406(DA) ;Delete 440.6 records when entry in 442 is deleted
  1. N IPIEN,HLDDA
  1. S IPIEN=0,HLDDA=0
  1. F S IPIEN=$O(^PRCH(440.6,"PO",DA,IPIEN)) Q:IPIEN'>0 D
  1. .S HLDDA=DA,DA=IPIEN
  1. .S DIK="^PRCH(440.6," D ^DIK
  1. .K DIK
  1. .S DA=HLDDA
  1. K IPIEN,HLDDA
  1. Q
  1. KLL4219(DA) ;Delete 421.9 records when entry in 442 is deleted
  1. N IPIEN,HLDDA,PONUM
  1. S PONUM=$P($G(^PRC(442,DA,0)),"^") Q:$G(PONUM)=""
  1. S IPIEN=0,HLDDA=DA
  1. F S IPIEN=$O(^PRCF(421.9,"B",PONUM,IPIEN)) Q:IPIEN'>0 D
  1. .S DA=IPIEN
  1. .S DIK="^PRCF(421.9," D ^DIK
  1. .K DIK
  1. S DA=HLDDA
  1. K IPIEN,HLDDA,PONUM
  1. Q