PRCH516P ;WOIFO/CR-VENDOR LOOKUP AND CONVERSION ;1/08/01 9:36 AM
;;5.1;IFCAP;**16**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
W !!,?10,"Illegal entry point...terminating",$C(7)
Q
A1 ;
; This routine is used by patch PRC*5.1*16 to complete a conversion of
; vendors, file #440, and to update the socioeconomic groups in
; the CODE INDEX file #420.6.
;
W !,?10,">>>>>> VENDOR CONVERSION - FILE #440 <<<<<<"
W !!,?10,">>>>>> CODE INDEX UPDATE - FILE #420.6 <<<<<<"
W !!,?5,"This program will gather all the vendors from the VENDOR file"
W !,?5,"(#440) with the socioeconomic group codes 'Q' and 'R' to"
W !,?5,"perform the following:"
W !
W !,?5,"The code 'Q' will be deleted and the code 'S'"
W !,?5,"will be added to the vendor if it does not have it."
W !
W !,?5,"The code 'R' will be replaced by the new code 'RV' and the"
W !,?5,"code 'S' will be added to the vendor if it does not have it."
W !
W !,?5,"The codes 'Q' and 'R' in the CODE INDEX file (#420.6)"
W !,?5,"will be deactivated as part of this patch.",!
W !,?5,"PLEASE OBTAIN A PRINTOUT OF ALL THE VENDORS BEFORE AND"
W !,?5,"AFTER THE CONVERSION AND SAVE BOTH FOR FUTURE REFERENCE."
;
K ^TMP($J,"PRCH516P")
S CONV=0
I $D(^TMP($J,"PRCH516P")) G START
E D START1 I '$D(^TMP($J,"PRCH516P")) D Q
. W !!,?5,"NO RECORDS FOUND...TERMINATING.",$C(7) D EXIT
START ;
W !!,?5,"Searching for all the eligible vendors, please wait..." H 2
W !!,?5,"...list completed and ready to be printed!!!",!,$C(7)
W !,?5,"(Enter '^' at the DEVICE prompt to quit.)",!!
I $D(^TMP($J,"PRCH516P"))&($G(CONV)=0) D A4 Q:POP
W !
S %A="Continue with the conversion",%B="",%=2
D ^PRCFYN G:%=2 EXIT
W !! S:%=1 CONV=1
Q:$G(CONV)'=1
;
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTDESC="VENDOR LOOKUP FOR CONVERSION - PATCH PRC*5.1*16",ZTRTN="A2^PRCH516P",ZTSAVE("^TMP($J,")="",ZTSAVE("CONV")="" D ^%ZTLOAD,HOME^%ZIS,EXIT Q
D A2,EXIT,^%ZISC
Q
;
START1 S X="" F S X=$O(^PRC(440,X)) Q:X="" S Z11=$G(^PRC(440,X,1.1,0)),CNTR=$P(Z11,"^",4) I CNTR>0 D
.S SEG="" F S SEG=$O(^PRC(440,X,1.1,SEG)) Q:SEG="" S:$G(SEG)=158 $P(^TMP($J,"PRCH516P",X),"^",1)=SEG S:$G(SEG)=159 $P(^TMP($J,"PRCH516P",X),"^",2)=SEG
.S CNTR=$G(CNTR)-1
.Q:CNTR=0
Q
;
EXIT K CNTR,CONV,COUNT,EX,I,J,N,P,PRCINDX,SEG,TDATE,X,XXZ,Y,Z11,^TMP($J,"PRCH516P")
Q
;
A2 ;Convert the vendor with intenal code 'Q'=158 to code 'S'=162 if code
;'S' is not present. If code 'S' is present, just delete code 'Q' and
;update the multiple header.
;
S J="" F S J=$O(^TMP($J,"PRCH516P",J)) Q:J=""!(J'>0) D:$P($G(^TMP($J,"PRCH516P",J)),"^",1)=158
.S PRCINDX=$P(^PRC(440,J,1.1,0),"^",4)
.I PRCINDX>0 D
..K ^PRC(440,J,1.1,158,0) S $P(^PRC(440,J,1.1,0),"^",4)=$P(^PRC(440,J,1.1,0),"^",4)-1
..I '$D(^PRC(440,J,1.1,162,0)) S $P(^PRC(440,J,1.1,162,0),"^",1)="162",$P(^PRC(440,J,1.1,0),"^",3)="162",$P(^PRC(440,J,1.1,0),"^",4)=$P(^PRC(440,J,1.1,0),"^",4)+1
..I $D(^PRC(440,J,1.1,162,0)) S $P(^PRC(440,J,1.1,0),"^",3)="162"
;
;Convert any vendor with code 'R'=159 to code 'RV'=167.
S J="" F S J=$O(^TMP($J,"PRCH516P",J)) Q:J=""!(J'>0) D:$P($G(^TMP($J,"PRCH516P",J)),"^",2)=159
.S PRCINDX=$P(^PRC(440,J,1.1,0),"^",4)
.I PRCINDX>0 D
..K ^PRC(440,J,1.1,159,0) S $P(^PRC(440,J,1.1,0),"^",4)=$P(^PRC(440,J,1.1,0),"^",4)-1
..;If code 'S' is not present, add it and update multiple header.
..I '$D(^PRC(440,J,1.1,162,0)) S $P(^PRC(440,J,1.1,162,0),"^",1)="162",$P(^PRC(440,J,1.1,0),"^",3)="162",$P(^PRC(440,J,1.1,0),"^",4)=$P(^PRC(440,J,1.1,0),"^",4)+1
..S $P(^PRC(440,J,1.1,0),"^",3)="167"
..S $P(^PRC(440,J,1.1,167,0),"^",1)="167",$P(^PRC(440,J,1.1,0),"^",4)=$P(^PRC(440,J,1.1,0),"^",4)+1
D A3
Q
;
A3 ;Get a record of vendors before and after conversion.
U IO
D NOW^%DTC S Y=% D DD^%DT S TDATE=Y
S (EX,P)=1,COUNT=0
I '$D(^TMP($J,"PRCH516P")) S P=1 D HEADER W !!!!!!,?10,"*** NO RECORDS TO PRINT ***" Q
;
S J="" F S J=$O(^TMP($J,"PRCH516P",J)) Q:EX="^" Q:J=""!(J'>0) D
.D:P=1 HEADER
.S PRCINDX=$P(^PRC(440,J,1.1,0),"^",4) I PRCINDX>0 D
..W ?2,J,?15,$P(^PRC(440,J,0),"^",1)
..S N="" F S N=$O(^PRC(440,J,1.1,N)) Q:N="" W:N>0 ?60,$P(^PRCD(420.6,N,0),"^",1)," "
..W !
..I (IOSL-$Y)<6 D HOLD Q:EX="^"
.S COUNT=COUNT+1
W !!,?5,"Found "_COUNT_" entries."
Q
;
HOLD ;
G HEADER:$P(IOST,"-")="P" W !,"Press return to continue, '^' to exit:" R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'["^" HEADER
Q
W @IOF
W !,"LIST OF VENDORS FOR PATCH PRC*5.1*16",?42,TDATE,?70,"PAGE ",P
W:$G(CONV)=1 !,"(AFTER CONVERSION)",!
W:$G(CONV)=0 !,"(BEFORE CONVERSION)",!
F I=1:1:8 W "----------"
W !,?2,"VENDOR ID",?15,"VENDOR NAME",?60,"VENDOR CODES",!!
S P=P+1
Q
;
A4 ;Allow the user to get a printout before conversion.
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTDESC="VENDOR LOOKUP FOR CONVERSION - PATCH PRC*5.1*16",ZTRTN="A3^PRCH516P",ZTSAVE("^TMP($J,")="",ZTSAVE("CONV")="" D ^%ZTLOAD,HOME^%ZIS Q
D A3,^%ZISC
Q
;
PRE ;Delete all the entries in file #420.6.
;This entry point is invoked from KIDS for installation of PRC*5.1*16
;and should not be used directly.
K ^PRCD(420.6)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH516P 5233 printed Sep 23, 2025@19:41:21 Page 2
PRCH516P ;WOIFO/CR-VENDOR LOOKUP AND CONVERSION ;1/08/01 9:36 AM
+1 ;;5.1;IFCAP;**16**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 WRITE !!,?10,"Illegal entry point...terminating",$CHAR(7)
+5 QUIT
A1 ;
+1 ; This routine is used by patch PRC*5.1*16 to complete a conversion of
+2 ; vendors, file #440, and to update the socioeconomic groups in
+3 ; the CODE INDEX file #420.6.
+4 ;
+5 WRITE !,?10,">>>>>> VENDOR CONVERSION - FILE #440 <<<<<<"
+6 WRITE !!,?10,">>>>>> CODE INDEX UPDATE - FILE #420.6 <<<<<<"
+7 WRITE !!,?5,"This program will gather all the vendors from the VENDOR file"
+8 WRITE !,?5,"(#440) with the socioeconomic group codes 'Q' and 'R' to"
+9 WRITE !,?5,"perform the following:"
+10 WRITE !
+11 WRITE !,?5,"The code 'Q' will be deleted and the code 'S'"
+12 WRITE !,?5,"will be added to the vendor if it does not have it."
+13 WRITE !
+14 WRITE !,?5,"The code 'R' will be replaced by the new code 'RV' and the"
+15 WRITE !,?5,"code 'S' will be added to the vendor if it does not have it."
+16 WRITE !
+17 WRITE !,?5,"The codes 'Q' and 'R' in the CODE INDEX file (#420.6)"
+18 WRITE !,?5,"will be deactivated as part of this patch.",!
+19 WRITE !,?5,"PLEASE OBTAIN A PRINTOUT OF ALL THE VENDORS BEFORE AND"
+20 WRITE !,?5,"AFTER THE CONVERSION AND SAVE BOTH FOR FUTURE REFERENCE."
+21 ;
+22 KILL ^TMP($JOB,"PRCH516P")
+23 SET CONV=0
+24 IF $DATA(^TMP($JOB,"PRCH516P"))
GOTO START
+25 IF '$TEST
DO START1
IF '$DATA(^TMP($JOB,"PRCH516P"))
Begin DoDot:1
+26 WRITE !!,?5,"NO RECORDS FOUND...TERMINATING.",$CHAR(7)
DO EXIT
End DoDot:1
QUIT
START ;
+1 WRITE !!,?5,"Searching for all the eligible vendors, please wait..."
HANG 2
+2 WRITE !!,?5,"...list completed and ready to be printed!!!",!,$CHAR(7)
+3 WRITE !,?5,"(Enter '^' at the DEVICE prompt to quit.)",!!
+4 IF $DATA(^TMP($JOB,"PRCH516P"))&($GET(CONV)=0)
DO A4
if POP
QUIT
+5 WRITE !
+6 SET %A="Continue with the conversion"
SET %B=""
SET %=2
+7 DO ^PRCFYN
if %=2
GOTO EXIT
+8 WRITE !!
if %=1
SET CONV=1
+9 if $GET(CONV)'=1
QUIT
+10 ;
+11 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+12 IF $DATA(IO("Q"))
SET ZTDESC="VENDOR LOOKUP FOR CONVERSION - PATCH PRC*5.1*16"
SET ZTRTN="A2^PRCH516P"
SET ZTSAVE("^TMP($J,")=""
SET ZTSAVE("CONV")=""
DO ^%ZTLOAD
DO HOME^%ZIS
DO EXIT
QUIT
+13 DO A2
DO EXIT
DO ^%ZISC
+14 QUIT
+15 ;
START1 SET X=""
FOR
SET X=$ORDER(^PRC(440,X))
if X=""
QUIT
SET Z11=$GET(^PRC(440,X,1.1,0))
SET CNTR=$PIECE(Z11,"^",4)
IF CNTR>0
Begin DoDot:1
+1 SET SEG=""
FOR
SET SEG=$ORDER(^PRC(440,X,1.1,SEG))
if SEG=""
QUIT
if $GET(SEG)=158
SET $PIECE(^TMP($JOB,"PRCH516P",X),"^",1)=SEG
if $GET(SEG)=159
SET $PIECE(^TMP($JOB,"PRCH516P",X),"^",2)=SEG
+2 SET CNTR=$GET(CNTR)-1
+3 if CNTR=0
QUIT
End DoDot:1
+4 QUIT
+5 ;
EXIT KILL CNTR,CONV,COUNT,EX,I,J,N,P,PRCINDX,SEG,TDATE,X,XXZ,Y,Z11,^TMP($JOB,"PRCH516P")
+1 QUIT
+2 ;
A2 ;Convert the vendor with intenal code 'Q'=158 to code 'S'=162 if code
+1 ;'S' is not present. If code 'S' is present, just delete code 'Q' and
+2 ;update the multiple header.
+3 ;
+4 SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"PRCH516P",J))
if J=""!(J'>0)
QUIT
if $PIECE($GET(^TMP($JOB,"PRCH516P",J)),"^",1)=158
Begin DoDot:1
+5 SET PRCINDX=$PIECE(^PRC(440,J,1.1,0),"^",4)
+6 IF PRCINDX>0
Begin DoDot:2
+7 KILL ^PRC(440,J,1.1,158,0)
SET $PIECE(^PRC(440,J,1.1,0),"^",4)=$PIECE(^PRC(440,J,1.1,0),"^",4)-1
+8 IF '$DATA(^PRC(440,J,1.1,162,0))
SET $PIECE(^PRC(440,J,1.1,162,0),"^",1)="162"
SET $PIECE(^PRC(440,J,1.1,0),"^",3)="162"
SET $PIECE(^PRC(440,J,1.1,0),"^",4)=$PIECE(^PRC(440,J,1.1,0),"^",4)+1
+9 IF $DATA(^PRC(440,J,1.1,162,0))
SET $PIECE(^PRC(440,J,1.1,0),"^",3)="162"
End DoDot:2
End DoDot:1
+10 ;
+11 ;Convert any vendor with code 'R'=159 to code 'RV'=167.
+12 SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"PRCH516P",J))
if J=""!(J'>0)
QUIT
if $PIECE($GET(^TMP($JOB,"PRCH516P",J)),"^",2)=159
Begin DoDot:1
+13 SET PRCINDX=$PIECE(^PRC(440,J,1.1,0),"^",4)
+14 IF PRCINDX>0
Begin DoDot:2
+15 KILL ^PRC(440,J,1.1,159,0)
SET $PIECE(^PRC(440,J,1.1,0),"^",4)=$PIECE(^PRC(440,J,1.1,0),"^",4)-1
+16 ;If code 'S' is not present, add it and update multiple header.
+17 IF '$DATA(^PRC(440,J,1.1,162,0))
SET $PIECE(^PRC(440,J,1.1,162,0),"^",1)="162"
SET $PIECE(^PRC(440,J,1.1,0),"^",3)="162"
SET $PIECE(^PRC(440,J,1.1,0),"^",4)=$PIECE(^PRC(440,J,1.1,0),"^",4)+1
+18 SET $PIECE(^PRC(440,J,1.1,0),"^",3)="167"
+19 SET $PIECE(^PRC(440,J,1.1,167,0),"^",1)="167"
SET $PIECE(^PRC(440,J,1.1,0),"^",4)=$PIECE(^PRC(440,J,1.1,0),"^",4)+1
End DoDot:2
End DoDot:1
+20 DO A3
+21 QUIT
+22 ;
A3 ;Get a record of vendors before and after conversion.
+1 USE IO
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TDATE=Y
+3 SET (EX,P)=1
SET COUNT=0
+4 IF '$DATA(^TMP($JOB,"PRCH516P"))
SET P=1
DO HEADER
WRITE !!!!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+5 ;
+6 SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"PRCH516P",J))
if EX="^"
QUIT
if J=""!(J'>0)
QUIT
Begin DoDot:1
+7 if P=1
DO HEADER
+8 SET PRCINDX=$PIECE(^PRC(440,J,1.1,0),"^",4)
IF PRCINDX>0
Begin DoDot:2
+9 WRITE ?2,J,?15,$PIECE(^PRC(440,J,0),"^",1)
+10 SET N=""
FOR
SET N=$ORDER(^PRC(440,J,1.1,N))
if N=""
QUIT
if N>0
WRITE ?60,$PIECE(^PRCD(420.6,N,0),"^",1)," "
+11 WRITE !
+12 IF (IOSL-$Y)<6
DO HOLD
if EX="^"
QUIT
End DoDot:2
+13 SET COUNT=COUNT+1
End DoDot:1
+14 WRITE !!,?5,"Found "_COUNT_" entries."
+15 QUIT
+16 ;
HOLD ;
+1 if $PIECE(IOST,"-")="P"
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit:"
READ XXZ:DTIME
if XXZ="^"
SET EX="^"
if '$TEST
SET EX="^"
if EX'["^"
DO HEADER
+2 QUIT
+1 WRITE @IOF
+2 WRITE !,"LIST OF VENDORS FOR PATCH PRC*5.1*16",?42,TDATE,?70,"PAGE ",P
+3 if $GET(CONV)=1
WRITE !,"(AFTER CONVERSION)",!
+4 if $GET(CONV)=0
WRITE !,"(BEFORE CONVERSION)",!
+5 FOR I=1:1:8
WRITE "----------"
+6 WRITE !,?2,"VENDOR ID",?15,"VENDOR NAME",?60,"VENDOR CODES",!!
+7 SET P=P+1
+8 QUIT
+9 ;
A4 ;Allow the user to get a printout before conversion.
+1 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
SET ZTDESC="VENDOR LOOKUP FOR CONVERSION - PATCH PRC*5.1*16"
SET ZTRTN="A3^PRCH516P"
SET ZTSAVE("^TMP($J,")=""
SET ZTSAVE("CONV")=""
DO ^%ZTLOAD
DO HOME^%ZIS
QUIT
+3 DO A3
DO ^%ZISC
+4 QUIT
+5 ;
PRE ;Delete all the entries in file #420.6.
+1 ;This entry point is invoked from KIDS for installation of PRC*5.1*16
+2 ;and should not be used directly.
+3 KILL ^PRCD(420.6)
+4 QUIT
