source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSF2.m@ 1297

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