PRCFFUA2 ;WISC/DJM-RESTORE BOC MULTIPLE & CLEAN UP CHANGES MULTIPLE ;2/13/95 3:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;THIS ROUTINE IS USED TO RESTORE THE BOC NODES, NODE 22, AND THE
;CHANGES NODES, NODE 6 - AMENDMENT - NODE 3, BACK TO THEIR VALUES
;PRIOR TO THE CURRENT AMENDMENT. THIS IS REQUIRED TO PROPERLY
;RE-GENERATE THE CURRENT AMENDMENT MO/SO DOCUMENT.
;
START ;SEARCH THROUGH THE AMENDMENT FOR BOC CHANGES. BOC CHANGES ARE
;ENTRIES WITH THE SECOND '^' PIECE EQUAL TO "".
N LOOP,VAL,OLD,ENTRY,FIELD,SUB,BOC,AMT,FMS
S LOOP=0
F S LOOP=$O(^PRC(442,PRCHPO,6,PRCHAM,3,LOOP)) Q:LOOP'>0 S VAL=$G(^(LOOP,0)) D:$P(VAL,U,2)=""
.S OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,LOOP,1,1,0))
.S ENTRY=$P(VAL,U,4)
.S FIELD=$P($P(VAL,U,3),";")
.S SUB=$P($P($P(VAL,U,3),":"),";",2)
.Q:SUB'="442.041"
.I FIELD=".01" D
..S BOC=$P(^PRC(442,PRCHPO,22,ENTRY,0),U)
..K ^PRC(442,PRCHPO,22,"B",BOC,ENTRY)
..S $P(^PRC(442,PRCHPO,22,ENTRY,0),U)=+OLD
..S ^PRC(442,PRCHPO,22,"B",+OLD,ENTRY)=""
..Q
.I FIELD="1" S $P(^PRC(442,PRCHPO,22,ENTRY,0),U,2)=OLD
.I FIELD="2" S $P(^PRC(442,PRCHPO,22,ENTRY,0),U,3)=OLD
.K ^PRC(442,PRCHPO,6,PRCHAM,3,LOOP)
.K ^PRC(442,PRCHPO,6,PRCHAM,3,"B",$P(VAL,U),LOOP)
.S $P(^PRC(442,PRCHPO,6,PRCHAM,3,0),U,4)=$P(^PRC(442,PRCHPO,6,PRCHAM,3,0),U,4)-1
.Q
;
ZERO ;NOW LETS REMOVE ANY ENTRIES IN NODE 22 WITH ALL THREE FIELDS
;SET TO '0'.
S LOOP=0
F S LOOP=$O(^PRC(442,PRCHPO,22,LOOP)) Q:LOOP'>0 D
.S VAL=$G(^PRC(442,PRCHPO,22,LOOP,0))
.S BOC=$P(VAL,U) Q:VAL>0
.S AMT=$P(VAL,U,2) Q:AMT>0
.S FMS=$P(VAL,U,3) Q:FMS>0
.K ^PRC(442,PRCHPO,22,LOOP,0),^PRC(442,PRCHPO,22,"B",BOC,LOOP)
.S $P(^PRC(442,PRCHPO,22,0),U,4)=$P(^PRC(442,PRCHPO,22,0),U,4)-1
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFUA2 1789 printed Dec 13, 2024@02:03:56 Page 2
PRCFFUA2 ;WISC/DJM-RESTORE BOC MULTIPLE & CLEAN UP CHANGES MULTIPLE ;2/13/95 3:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;THIS ROUTINE IS USED TO RESTORE THE BOC NODES, NODE 22, AND THE
+3 ;CHANGES NODES, NODE 6 - AMENDMENT - NODE 3, BACK TO THEIR VALUES
+4 ;PRIOR TO THE CURRENT AMENDMENT. THIS IS REQUIRED TO PROPERLY
+5 ;RE-GENERATE THE CURRENT AMENDMENT MO/SO DOCUMENT.
+6 ;
START ;SEARCH THROUGH THE AMENDMENT FOR BOC CHANGES. BOC CHANGES ARE
+1 ;ENTRIES WITH THE SECOND '^' PIECE EQUAL TO "".
+2 NEW LOOP,VAL,OLD,ENTRY,FIELD,SUB,BOC,AMT,FMS
+3 SET LOOP=0
+4 FOR
SET LOOP=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,LOOP))
if LOOP'>0
QUIT
SET VAL=$GET(^(LOOP,0))
if $PIECE(VAL,U,2)=""
Begin DoDot:1
+5 SET OLD=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,LOOP,1,1,0))
+6 SET ENTRY=$PIECE(VAL,U,4)
+7 SET FIELD=$PIECE($PIECE(VAL,U,3),";")
+8 SET SUB=$PIECE($PIECE($PIECE(VAL,U,3),":"),";",2)
+9 if SUB'="442.041"
QUIT
+10 IF FIELD=".01"
Begin DoDot:2
+11 SET BOC=$PIECE(^PRC(442,PRCHPO,22,ENTRY,0),U)
+12 KILL ^PRC(442,PRCHPO,22,"B",BOC,ENTRY)
+13 SET $PIECE(^PRC(442,PRCHPO,22,ENTRY,0),U)=+OLD
+14 SET ^PRC(442,PRCHPO,22,"B",+OLD,ENTRY)=""
+15 QUIT
End DoDot:2
+16 IF FIELD="1"
SET $PIECE(^PRC(442,PRCHPO,22,ENTRY,0),U,2)=OLD
+17 IF FIELD="2"
SET $PIECE(^PRC(442,PRCHPO,22,ENTRY,0),U,3)=OLD
+18 KILL ^PRC(442,PRCHPO,6,PRCHAM,3,LOOP)
+19 KILL ^PRC(442,PRCHPO,6,PRCHAM,3,"B",$PIECE(VAL,U),LOOP)
+20 SET $PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,0),U,4)=$PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,0),U,4)-1
+21 QUIT
End DoDot:1
+22 ;
ZERO ;NOW LETS REMOVE ANY ENTRIES IN NODE 22 WITH ALL THREE FIELDS
+1 ;SET TO '0'.
+2 SET LOOP=0
+3 FOR
SET LOOP=$ORDER(^PRC(442,PRCHPO,22,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+4 SET VAL=$GET(^PRC(442,PRCHPO,22,LOOP,0))
+5 SET BOC=$PIECE(VAL,U)
if VAL>0
QUIT
+6 SET AMT=$PIECE(VAL,U,2)
if AMT>0
QUIT
+7 SET FMS=$PIECE(VAL,U,3)
if FMS>0
QUIT
+8 KILL ^PRC(442,PRCHPO,22,LOOP,0),^PRC(442,PRCHPO,22,"B",BOC,LOOP)
+9 SET $PIECE(^PRC(442,PRCHPO,22,0),U,4)=$PIECE(^PRC(442,PRCHPO,22,0),U,4)-1
+10 QUIT
End DoDot:1
+11 QUIT
