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

PRCHSF2.m

Go to the documentation of this file.
  1. PRCHSF2 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/23/95 1:12 PM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;CONTINUATION OF 'PRCHSF1'
  1. DUPS ;CREAT ARRAY TO PREVENT DUPLICATES FROM BOC MULTIPLE IN CHANGES
  1. ;MULTIPLE.
  1. S C1=0 K ^TMP($J)
  1. F S C1=$O(^PRC(442,PRCHPO,6,PRCHAM,3,C1)) Q:C1'>0 D
  1. .S C2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,C1,0)) Q:C2=""
  1. .S RECORD=$P(C2,U,4)
  1. .S FF=$P(C2,U,3)
  1. .S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,C1)=""
  1. .Q
  1. CHANGES ;ANY DIFFERENCES IN THE BOC MULTIPLE NEED TO BE ADDED INTO 'CHANGES'
  1. S BOC=0 S:$D(DA(1)) PRCHDA1=DA(1) S PRCHDA=DA
  1. F S BOC=$O(^PRC(442,PRCHPO,22,BOC)) Q:BOC'>0 S OBOC=0 D
  1. .S BOC1=$G(^PRC(442,PRCHPO,22,BOC,0))
  1. .S DA(2)=PRCHPO,DA(1)=PRCHAM,LINO=$P(BOC1,U,3)
  1. C0 .I LINO=991 S OBOC=$G(^PRC(443.6,PRCHPO,22,BOC,0))
  1. .I LINO'=991 S OBOC=$O(^PRC(443.6,PRCHPO,22,"B",+$P(BOC1,U),OBOC))
  1. .I OBOC=""!(LINO=991) D Q
  1. ..S RECORD=BOC
  1. ..S FF=".01;442.041:41"
  1. ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) G:C1>0 CX
  1. ..S OLD=$S(LINO=991:$P(OBOC,U),1:0)
  1. ..I LINO=991,OLD=$P(BOC1,U) G CX
  1. ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
  1. C1 ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C1
  1. ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y,DIE=DIC
  1. ..S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
  1. ..D ^DIE
  1. ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
  1. CX ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
  1. ..S FF="1;442.041:41"
  1. ..S RECORD=BOC
  1. ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) G:C1>0 CY
  1. ..S OLD=$S(LINO=991:$P(OBOC,U,2),1:0)
  1. ..I LINO=991,OLD=$P(BOC1,U,2) G CY
  1. C1A ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C1A
  1. ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y,DIE=DIC
  1. ..S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
  1. ..D ^DIE
  1. ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
  1. CY ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
  1. ..Q:LINO=991
  1. ..S RECORD=BOC
  1. ..S FF="2;442.041:41"
  1. ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) Q:C1>0
  1. C1B ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C1B
  1. ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y
  1. ..S OLD=0,DIE=DIC
  1. ..S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
  1. ..D ^DIE
  1. ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
  1. ..Q
  1. CZ .S OBOC1=$G(^PRC(443.6,PRCHPO,22,OBOC,0)),OLINO=$P(OBOC1,U,3) G:OLINO'=LINO C0
  1. .S OLD=$P(OBOC1,U,2),FF="1;442.041:41",RECORD=BOC Q:OLD=$P(BOC1,U,2)
  1. .S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) Q:C1>0
  1. .S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
  1. C2 .S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C2
  1. .K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y,DIE=DIC
  1. .S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
  1. .D ^DIE
  1. .S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
  1. .Q
  1. ;LOOP THROUGH AGAIN, CHECKING FOR BOC AMOUNT = 0
  1. S BOC=0 F S BOC=$O(^PRC(442,PRCHPO,22,BOC)) Q:BOC'>0 D
  1. .S BOC1=$G(^PRC(442,PRCHPO,22,BOC,0)),AMNT=$P(BOC1,U,2),FMSNO=$P(BOC1,U,3)
  1. .I AMNT=0 D
  1. ..S OBOC=$O(^PRC(443.6,PRCHPO,22,"B",+$P(BOC1,U),0)) Q:OBOC'>0
  1. ..S OBOC1=$G(^PRC(443.6,PRCHPO,22,OBOC,0))
  1. ..S OLD=$P(OBOC1,U,2),FF="1;442.041:41",RECORD=BOC
  1. ..Q:OLD=AMNT
  1. ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) Q:C1>0
  1. ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
  1. C3 ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C3
  1. ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y
  1. ..S DIE=DIC,DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
  1. ..D ^DIE
  1. ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
  1. ..Q
  1. .Q
  1. ;
  1. Q L -^PRC(442,PRCHPO) K PRCHS,I,J,CNT,CTR,M,PTM
  1. K ^TMP($J)
  1. S:$D(PRCHDA1) DA(1)=PRCHDA1 S DA=PRCHDA K PRCHDA1,PRCHDA
  1. Q