- 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 Jan 18, 2025@03:11:53 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