44 lines
1.7 KiB
Mathematica
44 lines
1.7 KiB
Mathematica
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
|