PRCUPPC1.m

PRCUPPC1 ;WISC/RHD-ARCHIVING & PURGING ENTRY POINTS ;12/14/93  11:34 AM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, 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 K DIK,DA,DA(1)

 Q

P4426(PRCHYR) ;purge common number series by year

 ;have the year being purged, delete all number series that

 ;have the fiscal year field defined equal to the purge year

 Q:'PRCHYR

 N PRCHDA,X,DA,DIK

 S PRCHDA=0

 F  S PRCHDA=$O(^PRC(442.6,PRCHDA)) Q:'PRCHDA  I PRCHYR=$P($G(^PRC(442.6,PRCHDA,0)),"^",6) S DA=PRCHDA,DIK="^PRC(442.6," D ^DIK K DIK,DA

 Q

DL424(PRC442) N PRC424

 S PRC424=0 F  S PRC424=$O(^PRC(424,"C",PRC442,PRC424)) Q:PRC424'?1.N  D

 .D DL424D1 Q:'$D(^PRC(424,PRC424,0))  S DIK="^PRC(424,",DA=PRC424 D ^DIK K DIK,DA

 .QUIT

 Q

DL424D1 ;

 N PRC424D1 S PRC424D1=0

 S PRC424D1=$O(^PRC(424.1,"C",PRC424,PRC424D1)) Q:PRC424D1'?1.N  D

 .Q:'$D(^PRC(424.1,PRC424D1,0))

 .S DA=PRC424D1,DIK="^PRC(424.1," D ^DIK K DIK,DA

 .Q

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCUPPC1   1868     printed  Apr 23, 2025@18:34:21                                                                                                                                                                                                    Page 2

PRCUPPC1  ;WISC/RHD-ARCHIVING & PURGING ENTRY POINTS ;12/14/93  11:34 AM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, 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

                   KILL DIK,DA,DA(1)

               End DoDot:1

 +11       QUIT 

P4426(PRCHYR) ;purge common number series by year

 +1       ;have the year being purged, delete all number series that

 +2       ;have the fiscal year field defined equal to the purge year

 +3        if 'PRCHYR

               QUIT 

 +4        NEW PRCHDA,X,DA,DIK

 +5        SET PRCHDA=0

 +6        FOR 

               SET PRCHDA=$ORDER(^PRC(442.6,PRCHDA))

               if 'PRCHDA

                   QUIT 

               IF PRCHYR=$PIECE($GET(^PRC(442.6,PRCHDA,0)),"^",6)

                   SET DA=PRCHDA

                   SET DIK="^PRC(442.6,"

                   DO ^DIK

                   KILL DIK,DA

 +7        QUIT 

DL424(PRC442)  NEW PRC424

 +1        SET PRC424=0

           FOR 

               SET PRC424=$ORDER(^PRC(424,"C",PRC442,PRC424))

               if PRC424'?1.N

                   QUIT 

               Begin DoDot:1

 +2                DO DL424D1

                   if '$DATA(^PRC(424,PRC424,0))

                       QUIT 

                   SET DIK="^PRC(424,"

                   SET DA=PRC424

                   DO ^DIK

                   KILL DIK,DA

 +3                QUIT 

               End DoDot:1

 +4        QUIT 

DL424D1   ;

 +1        NEW PRC424D1

           SET PRC424D1=0

 +2        SET PRC424D1=$ORDER(^PRC(424.1,"C",PRC424,PRC424D1))

           if PRC424D1'?1.N

               QUIT 

           Begin DoDot:1

 +3            if '$DATA(^PRC(424.1,PRC424D1,0))

                   QUIT 

 +4            SET DA=PRC424D1

               SET DIK="^PRC(424.1,"

               DO ^DIK

               KILL DIK,DA

 +5            QUIT 

           End DoDot:1

 +6        QUIT