source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGPPC1.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.4 KB
Line 
1PRCGPPC1 ;WIRMFO@ALTOONA/CTB/WIRMFO/RHD - ARCHIVING & PURGING ENTRY POINTS ;12/10/97 10:55 AM
2V ;;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
5P4429(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
16P441(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
28DL424(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
33DL424D1 ;
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
Note: See TracBrowser for help on using the repository browser.