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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHSF2 4096 printed Sep 23, 2025@19:46:46 Page 2
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
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;CONTINUATION OF 'PRCHSF1'
DUPS ;CREAT ARRAY TO PREVENT DUPLICATES FROM BOC MULTIPLE IN CHANGES
+1 ;MULTIPLE.
+2 SET C1=0
KILL ^TMP($JOB)
+3 FOR
SET C1=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,C1))
if C1'>0
QUIT
Begin DoDot:1
+4 SET C2=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,C1,0))
if C2=""
QUIT
+5 SET RECORD=$PIECE(C2,U,4)
+6 SET FF=$PIECE(C2,U,3)
+7 SET ^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,C1)=""
+8 QUIT
End DoDot:1
CHANGES ;ANY DIFFERENCES IN THE BOC MULTIPLE NEED TO BE ADDED INTO 'CHANGES'
+1 SET BOC=0
if $DATA(DA(1))
SET PRCHDA1=DA(1)
SET PRCHDA=DA
+2 FOR
SET BOC=$ORDER(^PRC(442,PRCHPO,22,BOC))
if BOC'>0
QUIT
SET OBOC=0
Begin DoDot:1
+3 SET BOC1=$GET(^PRC(442,PRCHPO,22,BOC,0))
+4 SET DA(2)=PRCHPO
SET DA(1)=PRCHAM
SET LINO=$PIECE(BOC1,U,3)
C0 IF LINO=991
SET OBOC=$GET(^PRC(443.6,PRCHPO,22,BOC,0))
+1 IF LINO'=991
SET OBOC=$ORDER(^PRC(443.6,PRCHPO,22,"B",+$PIECE(BOC1,U),OBOC))
+2 IF OBOC=""!(LINO=991)
Begin DoDot:2
+3 SET RECORD=BOC
+4 SET FF=".01;442.041:41"
+5 SET C1=$ORDER(^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,0))
if C1>0
GOTO CX
+6 SET OLD=$SELECT(LINO=991:$PIECE(OBOC,U),1:0)
+7 IF LINO=991
IF OLD=$PIECE(BOC1,U)
GOTO CX
+8 SET NEXT=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,0))
SET NEXT=$PIECE(NEXT,U,3)
C1 SET NEXT=NEXT+1
SET TEST=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0))
if TEST]""
GOTO C1
+1 KILL DD,DO,DR
SET X=NEXT
SET DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,"
SET DIC(0)="L"
DO FILE^DICN
if +Y'>0
QUIT
SET DA=+Y
SET DIE=DIC
+2 SET DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
+3 DO ^DIE
+4 SET ^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
CX SET NEXT=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,0))
SET NEXT=$PIECE(NEXT,U,3)
+1 SET FF="1;442.041:41"
+2 SET RECORD=BOC
+3 SET C1=$ORDER(^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,0))
if C1>0
GOTO CY
+4 SET OLD=$SELECT(LINO=991:$PIECE(OBOC,U,2),1:0)
+5 IF LINO=991
IF OLD=$PIECE(BOC1,U,2)
GOTO CY
C1A SET NEXT=NEXT+1
SET TEST=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0))
if TEST]""
GOTO C1A
+1 KILL DD,DO,DR
SET X=NEXT
SET DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,"
SET DIC(0)="L"
DO FILE^DICN
if +Y'>0
QUIT
SET DA=+Y
SET DIE=DIC
+2 SET DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
+3 DO ^DIE
+4 SET ^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
CY SET NEXT=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,0))
SET NEXT=$PIECE(NEXT,U,3)
+1 if LINO=991
QUIT
+2 SET RECORD=BOC
+3 SET FF="2;442.041:41"
+4 SET C1=$ORDER(^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,0))
if C1>0
QUIT
C1B SET NEXT=NEXT+1
SET TEST=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0))
if TEST]""
GOTO C1B
+1 KILL DD,DO,DR
SET X=NEXT
SET DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,"
SET DIC(0)="L"
DO FILE^DICN
if +Y'>0
QUIT
SET DA=+Y
+2 SET OLD=0
SET DIE=DIC
+3 SET DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
+4 DO ^DIE
+5 SET ^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
+6 QUIT
End DoDot:2
QUIT
CZ SET OBOC1=$GET(^PRC(443.6,PRCHPO,22,OBOC,0))
SET OLINO=$PIECE(OBOC1,U,3)
if OLINO'=LINO
GOTO C0
+1 SET OLD=$PIECE(OBOC1,U,2)
SET FF="1;442.041:41"
SET RECORD=BOC
if OLD=$PIECE(BOC1,U,2)
QUIT
+2 SET C1=$ORDER(^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,0))
if C1>0
QUIT
+3 SET NEXT=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,0))
SET NEXT=$PIECE(NEXT,U,3)
C2 SET NEXT=NEXT+1
SET TEST=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0))
if TEST]""
GOTO C2
+1 KILL DD,DO,DR
SET X=NEXT
SET DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,"
SET DIC(0)="L"
DO FILE^DICN
if +Y'>0
QUIT
SET DA=+Y
SET DIE=DIC
+2 SET DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
+3 DO ^DIE
+4 SET ^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
+5 QUIT
End DoDot:1
+6 ;LOOP THROUGH AGAIN, CHECKING FOR BOC AMOUNT = 0
+7 SET BOC=0
FOR
SET BOC=$ORDER(^PRC(442,PRCHPO,22,BOC))
if BOC'>0
QUIT
Begin DoDot:1
+8 SET BOC1=$GET(^PRC(442,PRCHPO,22,BOC,0))
SET AMNT=$PIECE(BOC1,U,2)
SET FMSNO=$PIECE(BOC1,U,3)
+9 IF AMNT=0
Begin DoDot:2
+10 SET OBOC=$ORDER(^PRC(443.6,PRCHPO,22,"B",+$PIECE(BOC1,U),0))
if OBOC'>0
QUIT
+11 SET OBOC1=$GET(^PRC(443.6,PRCHPO,22,OBOC,0))
+12 SET OLD=$PIECE(OBOC1,U,2)
SET FF="1;442.041:41"
SET RECORD=BOC
+13 if OLD=AMNT
QUIT
+14 SET C1=$ORDER(^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,0))
if C1>0
QUIT
+15 SET NEXT=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,0))
SET NEXT=$PIECE(NEXT,U,3)
C3 SET NEXT=NEXT+1
SET TEST=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0))
if TEST]""
GOTO C3
+1 KILL DD,DO,DR
SET X=NEXT
SET DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,"
SET DIC(0)="L"
DO FILE^DICN
if +Y'>0
QUIT
SET DA=+Y
+2 SET DIE=DIC
SET DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
+3 DO ^DIE
+4 SET ^TMP($JOB,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 ;
Q LOCK -^PRC(442,PRCHPO)
KILL PRCHS,I,J,CNT,CTR,M,PTM
+1 KILL ^TMP($JOB)
+2 if $DATA(PRCHDA1)
SET DA(1)=PRCHDA1
SET DA=PRCHDA
KILL PRCHDA1,PRCHDA
+3 QUIT
