- 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 Jan 18, 2025@03:05:08 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