- 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 Feb 18, 2025@23:31:17 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