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