PRCHDEL.m

PRCHDEL ;WISC/AKS-CHECKING OLDER AMENDMENTS ;

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 N PO,AM,X,EXPO,EXPO1,AUTODEL,N,PRCTMP

 S PO=0 F  S PO=$O(^PRC(443.6,PO)) Q:'PO  D

 .S AM=0 F  S AM=$O(^PRC(443.6,PO,6,AM)) Q:'AM  I $D(^PRC(443.6,PO,6,AM,0)) D

 ..;X variable created with NOW^%DTC must be available for DW^%DTC.

 ..D NOW^%DTC I X'<$P($P(^PRC(443.6,PO,6,AM,0),U,12),".") D

 ...I $P($G(^PRC(443.6,PO,6,AM,1)),U,2)]"" D  Q

 ....I $G(X)>0 D DW^%DTC I X="SATURDAY"!(X="SUNDAY") Q

 ....N SUBINFO S SUBINFO="443.67^15^"_AM

 ....D GENDIQ^PRCFFU7(443.6,+PO,50,"IEN",SUBINFO)

 ....S AUTODEL=$G(PRCTMP(443.67,+AM,15,"E"))

 ....D BULLET^PRCHAMBL(+PO,+AM,AUTODEL)

 ...S EXPO=$P(^PRC(443.6,PO,0),U),EXPO1=$P(EXPO,"-",2)

 ...S N=0 F  S N=$O(^PRC(441.7,"B",EXPO,N)) Q:N'>0  D

 ....S DA=N,DIE=441.7,DR=".01///@" D ^DIE K DA,DIE,DR

 ...K ^PRC(443.6,"B",EXPO),^PRC(443.6,"C",PO),^PRC(443.6,"D",PO)

 ...K ^PRC(443.6,"E",EXPO1),^PRC(443.6,PO)

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHDEL   1006     printed  Apr 09, 2024@21:08:12                                                                                                                                                                                                     Page 2

PRCHDEL   ;WISC/AKS-CHECKING OLDER AMENDMENTS ;

 +1       ;;5.1;IFCAP;;Oct 20, 2000

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        NEW PO,AM,X,EXPO,EXPO1,AUTODEL,N,PRCTMP

 +4        SET PO=0

           FOR 

               SET PO=$ORDER(^PRC(443.6,PO))

               if 'PO

                   QUIT 

               Begin DoDot:1

 +5                SET AM=0

                   FOR 

                       SET AM=$ORDER(^PRC(443.6,PO,6,AM))

                       if 'AM

                           QUIT 

                       IF $DATA(^PRC(443.6,PO,6,AM,0))

                           Begin DoDot:2

 +6       ;X variable created with NOW^%DTC must be available for DW^%DTC.

 +7                            DO NOW^%DTC

                               IF X'<$PIECE($PIECE(^PRC(443.6,PO,6,AM,0),U,12),".")

                                   Begin DoDot:3

 +8                                    IF $PIECE($GET(^PRC(443.6,PO,6,AM,1)),U,2)]""

                                           Begin DoDot:4

 +9                                            IF $GET(X)>0

                                                   DO DW^%DTC

                                                   IF X="SATURDAY"!(X="SUNDAY")

                                                       QUIT 

 +10                                           NEW SUBINFO

                                               SET SUBINFO="443.67^15^"_AM

 +11                                           DO GENDIQ^PRCFFU7(443.6,+PO,50,"IEN",SUBINFO)

 +12                                           SET AUTODEL=$GET(PRCTMP(443.67,+AM,15,"E"))

 +13                                           DO BULLET^PRCHAMBL(+PO,+AM,AUTODEL)

                                           End DoDot:4

                                           QUIT 

 +14                                   SET EXPO=$PIECE(^PRC(443.6,PO,0),U)

                                       SET EXPO1=$PIECE(EXPO,"-",2)

 +15                                   SET N=0

                                       FOR 

                                           SET N=$ORDER(^PRC(441.7,"B",EXPO,N))

                                           if N'>0

                                               QUIT 

                                           Begin DoDot:4

 +16                                           SET DA=N

                                               SET DIE=441.7

                                               SET DR=".01///@"

                                               DO ^DIE

                                               KILL DA,DIE,DR

                                           End DoDot:4

 +17                                   KILL ^PRC(443.6,"B",EXPO),^PRC(443.6,"C",PO),^PRC(443.6,"D",PO)

 +18                                   KILL ^PRC(443.6,"E",EXPO1),^PRC(443.6,PO)

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +19       QUIT