PRCGPPC1 ;WIRMFO@ALTOONA/CTB/WIRMFO/RHD - ARCHIVING & PURGING ENTRY POINTS ;12/10/97 10:55 AM
V ;;5.1;IFCAP;**95**;Oct 20, 2000
;Per VHA Directive 2004-038, this routine should not be modified.
;MUST BE CALLED FROM SPECIFIC ENTRY POINT
P4429(PO) ;given the external PO number, delete all entries in 442.9
;PO1 - full external PO number with a period and partial number
;DA - record number for 442.9
QUIT:PO=""
N DIK,DA,PO1
S PO1=PO_"."
S DIK="^PRC(442.9,"
F S PO1=$O(^PRC(442.9,"B",PO1)) Q:PO1=""!($P(PO1,".")'=PO) D
. F S DA=$O(^PRC(442.9,"B",PO1,0)) Q:'DA D ^DIK
. QUIT
QUIT
P441(PRCHDA) ;given the internal PO number, delete its entries in file 441
;this gets the FCP and repetitive item number(s) for the PO, and
;deletes the PO from the item(s) in 441
Q:'PRCHDA!('$D(^PRC(442,PRCHDA,0)))
N PRCHFCP,PRCHITEM,X,DIK,DA
S X=^PRC(442,PRCHDA,0),PRCHFCP=+$P(X,"^",1)_$P($P(X,"^",3)," ",1)
Q:PRCHFCP=""
S PRCHITEM=""
F S PRCHITEM=$O(^PRC(442,PRCHDA,2,"AE",PRCHITEM)) Q:'PRCHITEM D
.S DA=PRCHDA,DA(1)=PRCHFCP,DA(2)=PRCHITEM,DIK="^PRC(441,"_DA(2)_",4,"_DA(1)_",1,"
.D ^DIK
Q
DL424(PRC442) N PRC424,DA,DIK
S PRC424=0 F S PRC424=$O(^PRC(424,"C",PRC442,PRC424)) Q:PRC424'?1.N D
.D DL424D1 S DIK="^PRC(424,",DA=PRC424 D ^DIK
.QUIT
Q
DL424D1 ;
N PRC424D1,DA,DIK
S PRC424D1=0
F S PRC424D1=$O(^PRC(424.1,"C",PRC424,PRC424D1)) Q:PRC424D1'?1.N D
.S DA=PRC424D1,DIK="^PRC(424.1," D ^DIK
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGPPC1 1461 printed Dec 13, 2024@02:04:54 Page 2
PRCGPPC1 ;WIRMFO@ALTOONA/CTB/WIRMFO/RHD - ARCHIVING & PURGING ENTRY POINTS ;12/10/97 10:55 AM
V ;;5.1;IFCAP;**95**;Oct 20, 2000
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;MUST BE CALLED FROM SPECIFIC ENTRY POINT
P4429(PO) ;given the external PO number, delete all entries in 442.9
+1 ;PO1 - full external PO number with a period and partial number
+2 ;DA - record number for 442.9
+3 if PO=""
QUIT
+4 NEW DIK,DA,PO1
+5 SET PO1=PO_"."
+6 SET DIK="^PRC(442.9,"
+7 FOR
SET PO1=$ORDER(^PRC(442.9,"B",PO1))
if PO1=""!($PIECE(PO1,".")'=PO)
QUIT
Begin DoDot:1
+8 FOR
SET DA=$ORDER(^PRC(442.9,"B",PO1,0))
if 'DA
QUIT
DO ^DIK
+9 QUIT
End DoDot:1
+10 QUIT
P441(PRCHDA) ;given the internal PO number, delete its entries in file 441
+1 ;this gets the FCP and repetitive item number(s) for the PO, and
+2 ;deletes the PO from the item(s) in 441
+3 if 'PRCHDA!('$DATA(^PRC(442,PRCHDA,0)))
QUIT
+4 NEW PRCHFCP,PRCHITEM,X,DIK,DA
+5 SET X=^PRC(442,PRCHDA,0)
SET PRCHFCP=+$PIECE(X,"^",1)_$PIECE($PIECE(X,"^",3)," ",1)
+6 if PRCHFCP=""
QUIT
+7 SET PRCHITEM=""
+8 FOR
SET PRCHITEM=$ORDER(^PRC(442,PRCHDA,2,"AE",PRCHITEM))
if 'PRCHITEM
QUIT
Begin DoDot:1
+9 SET DA=PRCHDA
SET DA(1)=PRCHFCP
SET DA(2)=PRCHITEM
SET DIK="^PRC(441,"_DA(2)_",4,"_DA(1)_",1,"
+10 DO ^DIK
End DoDot:1
+11 QUIT
DL424(PRC442) NEW PRC424,DA,DIK
+1 SET PRC424=0
FOR
SET PRC424=$ORDER(^PRC(424,"C",PRC442,PRC424))
if PRC424'?1.N
QUIT
Begin DoDot:1
+2 DO DL424D1
SET DIK="^PRC(424,"
SET DA=PRC424
DO ^DIK
+3 QUIT
End DoDot:1
+4 QUIT
DL424D1 ;
+1 NEW PRC424D1,DA,DIK
+2 SET PRC424D1=0
+3 FOR
SET PRC424D1=$ORDER(^PRC(424.1,"C",PRC424,PRC424D1))
if PRC424D1'?1.N
QUIT
Begin DoDot:1
+4 SET DA=PRC424D1
SET DIK="^PRC(424.1,"
DO ^DIK
+5 QUIT
End DoDot:1
+6 QUIT
