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 ---[H[J[2J[HPRCHDEL 1006 printed Dec 13, 2024@02:06:34 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
