| 1 | PRCGPPC1 ;WIRMFO@ALTOONA/CTB/WIRMFO/RHD - ARCHIVING & PURGING ENTRY POINTS ;12/10/97 10:55 AM
|
|---|
| 2 | V ;;5.1;IFCAP;**95**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;MUST BE CALLED FROM SPECIFIC ENTRY POINT
|
|---|
| 5 | P4429(PO) ;given the external PO number, delete all entries in 442.9
|
|---|
| 6 | ;PO1 - full external PO number with a period and partial number
|
|---|
| 7 | ;DA - record number for 442.9
|
|---|
| 8 | QUIT:PO=""
|
|---|
| 9 | N DIK,DA,PO1
|
|---|
| 10 | S PO1=PO_"."
|
|---|
| 11 | S DIK="^PRC(442.9,"
|
|---|
| 12 | F S PO1=$O(^PRC(442.9,"B",PO1)) Q:PO1=""!($P(PO1,".")'=PO) D
|
|---|
| 13 | . F S DA=$O(^PRC(442.9,"B",PO1,0)) Q:'DA D ^DIK
|
|---|
| 14 | . QUIT
|
|---|
| 15 | QUIT
|
|---|
| 16 | P441(PRCHDA) ;given the internal PO number, delete its entries in file 441
|
|---|
| 17 | ;this gets the FCP and repetitive item number(s) for the PO, and
|
|---|
| 18 | ;deletes the PO from the item(s) in 441
|
|---|
| 19 | Q:'PRCHDA!('$D(^PRC(442,PRCHDA,0)))
|
|---|
| 20 | N PRCHFCP,PRCHITEM,X,DIK,DA
|
|---|
| 21 | S X=^PRC(442,PRCHDA,0),PRCHFCP=+$P(X,"^",1)_$P($P(X,"^",3)," ",1)
|
|---|
| 22 | Q:PRCHFCP=""
|
|---|
| 23 | S PRCHITEM=""
|
|---|
| 24 | F S PRCHITEM=$O(^PRC(442,PRCHDA,2,"AE",PRCHITEM)) Q:'PRCHITEM D
|
|---|
| 25 | .S DA=PRCHDA,DA(1)=PRCHFCP,DA(2)=PRCHITEM,DIK="^PRC(441,"_DA(2)_",4,"_DA(1)_",1,"
|
|---|
| 26 | .D ^DIK
|
|---|
| 27 | Q
|
|---|
| 28 | DL424(PRC442) N PRC424,DA,DIK
|
|---|
| 29 | S PRC424=0 F S PRC424=$O(^PRC(424,"C",PRC442,PRC424)) Q:PRC424'?1.N D
|
|---|
| 30 | .D DL424D1 S DIK="^PRC(424,",DA=PRC424 D ^DIK
|
|---|
| 31 | .QUIT
|
|---|
| 32 | Q
|
|---|
| 33 | DL424D1 ;
|
|---|
| 34 | N PRC424D1,DA,DIK
|
|---|
| 35 | S PRC424D1=0
|
|---|
| 36 | F S PRC424D1=$O(^PRC(424.1,"C",PRC424,PRC424D1)) Q:PRC424D1'?1.N D
|
|---|
| 37 | .S DA=PRC424D1,DIK="^PRC(424.1," D ^DIK
|
|---|
| 38 | .Q
|
|---|
| 39 | Q
|
|---|
