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