Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCFFUA2

PRCFFUA2.m

Go to the documentation of this file.
  1. PRCFFUA2 ;WISC/DJM-RESTORE BOC MULTIPLE & CLEAN UP CHANGES MULTIPLE ;2/13/95 3:08 PM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;THIS ROUTINE IS USED TO RESTORE THE BOC NODES, NODE 22, AND THE
  1. ;CHANGES NODES, NODE 6 - AMENDMENT - NODE 3, BACK TO THEIR VALUES
  1. ;PRIOR TO THE CURRENT AMENDMENT. THIS IS REQUIRED TO PROPERLY
  1. ;RE-GENERATE THE CURRENT AMENDMENT MO/SO DOCUMENT.
  1. ;
  1. START ;SEARCH THROUGH THE AMENDMENT FOR BOC CHANGES. BOC CHANGES ARE
  1. ;ENTRIES WITH THE SECOND '^' PIECE EQUAL TO "".
  1. N LOOP,VAL,OLD,ENTRY,FIELD,SUB,BOC,AMT,FMS
  1. S LOOP=0
  1. F S LOOP=$O(^PRC(442,PRCHPO,6,PRCHAM,3,LOOP)) Q:LOOP'>0 S VAL=$G(^(LOOP,0)) D:$P(VAL,U,2)=""
  1. .S OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,LOOP,1,1,0))
  1. .S ENTRY=$P(VAL,U,4)
  1. .S FIELD=$P($P(VAL,U,3),";")
  1. .S SUB=$P($P($P(VAL,U,3),":"),";",2)
  1. .Q:SUB'="442.041"
  1. .I FIELD=".01" D
  1. ..S BOC=$P(^PRC(442,PRCHPO,22,ENTRY,0),U)
  1. ..K ^PRC(442,PRCHPO,22,"B",BOC,ENTRY)
  1. ..S $P(^PRC(442,PRCHPO,22,ENTRY,0),U)=+OLD
  1. ..S ^PRC(442,PRCHPO,22,"B",+OLD,ENTRY)=""
  1. ..Q
  1. .I FIELD="1" S $P(^PRC(442,PRCHPO,22,ENTRY,0),U,2)=OLD
  1. .I FIELD="2" S $P(^PRC(442,PRCHPO,22,ENTRY,0),U,3)=OLD
  1. .K ^PRC(442,PRCHPO,6,PRCHAM,3,LOOP)
  1. .K ^PRC(442,PRCHPO,6,PRCHAM,3,"B",$P(VAL,U),LOOP)
  1. .S $P(^PRC(442,PRCHPO,6,PRCHAM,3,0),U,4)=$P(^PRC(442,PRCHPO,6,PRCHAM,3,0),U,4)-1
  1. .Q
  1. ;
  1. ZERO ;NOW LETS REMOVE ANY ENTRIES IN NODE 22 WITH ALL THREE FIELDS
  1. ;SET TO '0'.
  1. S LOOP=0
  1. F S LOOP=$O(^PRC(442,PRCHPO,22,LOOP)) Q:LOOP'>0 D
  1. .S VAL=$G(^PRC(442,PRCHPO,22,LOOP,0))
  1. .S BOC=$P(VAL,U) Q:VAL>0
  1. .S AMT=$P(VAL,U,2) Q:AMT>0
  1. .S FMS=$P(VAL,U,3) Q:FMS>0
  1. .K ^PRC(442,PRCHPO,22,LOOP,0),^PRC(442,PRCHPO,22,"B",BOC,LOOP)
  1. .S $P(^PRC(442,PRCHPO,22,0),U,4)=$P(^PRC(442,PRCHPO,22,0),U,4)-1
  1. .Q
  1. Q