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

PRCGPPC1.m

Go to the documentation of this file.
  1. PRCGPPC1 ;WIRMFO@ALTOONA/CTB/WIRMFO/RHD - ARCHIVING & PURGING ENTRY POINTS ;12/10/97 10:55 AM
  1. V ;;5.1;IFCAP;**95**;Oct 20, 2000
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;MUST BE CALLED FROM SPECIFIC ENTRY POINT
  1. 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
  1. ;DA - record number for 442.9
  1. QUIT:PO=""
  1. N DIK,DA,PO1
  1. S PO1=PO_"."
  1. S DIK="^PRC(442.9,"
  1. F S PO1=$O(^PRC(442.9,"B",PO1)) Q:PO1=""!($P(PO1,".")'=PO) D
  1. . F S DA=$O(^PRC(442.9,"B",PO1,0)) Q:'DA D ^DIK
  1. . QUIT
  1. QUIT
  1. 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
  1. ;deletes the PO from the item(s) in 441
  1. Q:'PRCHDA!('$D(^PRC(442,PRCHDA,0)))
  1. N PRCHFCP,PRCHITEM,X,DIK,DA
  1. S X=^PRC(442,PRCHDA,0),PRCHFCP=+$P(X,"^",1)_$P($P(X,"^",3)," ",1)
  1. Q:PRCHFCP=""
  1. S PRCHITEM=""
  1. F S PRCHITEM=$O(^PRC(442,PRCHDA,2,"AE",PRCHITEM)) Q:'PRCHITEM D
  1. .S DA=PRCHDA,DA(1)=PRCHFCP,DA(2)=PRCHITEM,DIK="^PRC(441,"_DA(2)_",4,"_DA(1)_",1,"
  1. .D ^DIK
  1. Q
  1. DL424(PRC442) N PRC424,DA,DIK
  1. S PRC424=0 F S PRC424=$O(^PRC(424,"C",PRC442,PRC424)) Q:PRC424'?1.N D
  1. .D DL424D1 S DIK="^PRC(424,",DA=PRC424 D ^DIK
  1. .QUIT
  1. Q
  1. DL424D1 ;
  1. N PRC424D1,DA,DIK
  1. S PRC424D1=0
  1. F S PRC424D1=$O(^PRC(424.1,"C",PRC424,PRC424D1)) Q:PRC424D1'?1.N D
  1. .S DA=PRC424D1,DIK="^PRC(424.1," D ^DIK
  1. .Q
  1. Q