source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH516P.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.0 KB
RevLine 
[613]1PRCH516P ;WOIFO/CR-VENDOR LOOKUP AND CONVERSION ;1/08/01 9:36 AM
2 ;;5.1;IFCAP;**16**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 W !!,?10,"Illegal entry point...terminating",$C(7)
6 Q
7A1 ;
8 ; This routine is used by patch PRC*5.1*16 to complete a conversion of
9 ; vendors, file #440, and to update the socioeconomic groups in
10 ; the CODE INDEX file #420.6.
11 ;
12 W !,?10,">>>>>> VENDOR CONVERSION - FILE #440 <<<<<<"
13 W !!,?10,">>>>>> CODE INDEX UPDATE - FILE #420.6 <<<<<<"
14 W !!,?5,"This program will gather all the vendors from the VENDOR file"
15 W !,?5,"(#440) with the socioeconomic group codes 'Q' and 'R' to"
16 W !,?5,"perform the following:"
17 W !
18 W !,?5,"The code 'Q' will be deleted and the code 'S'"
19 W !,?5,"will be added to the vendor if it does not have it."
20 W !
21 W !,?5,"The code 'R' will be replaced by the new code 'RV' and the"
22 W !,?5,"code 'S' will be added to the vendor if it does not have it."
23 W !
24 W !,?5,"The codes 'Q' and 'R' in the CODE INDEX file (#420.6)"
25 W !,?5,"will be deactivated as part of this patch.",!
26 W !,?5,"PLEASE OBTAIN A PRINTOUT OF ALL THE VENDORS BEFORE AND"
27 W !,?5,"AFTER THE CONVERSION AND SAVE BOTH FOR FUTURE REFERENCE."
28 ;
29 K ^TMP($J,"PRCH516P")
30 S CONV=0
31 I $D(^TMP($J,"PRCH516P")) G START
32 E D START1 I '$D(^TMP($J,"PRCH516P")) D Q
33 . W !!,?5,"NO RECORDS FOUND...TERMINATING.",$C(7) D EXIT
34START ;
35 W !!,?5,"Searching for all the eligible vendors, please wait..." H 2
36 W !!,?5,"...list completed and ready to be printed!!!",!,$C(7)
37 W !,?5,"(Enter '^' at the DEVICE prompt to quit.)",!!
38 I $D(^TMP($J,"PRCH516P"))&($G(CONV)=0) D A4 Q:POP
39 W !
40 S %A="Continue with the conversion",%B="",%=2
41 D ^PRCFYN G:%=2 EXIT
42 W !! S:%=1 CONV=1
43 Q:$G(CONV)'=1
44 ;
45 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
46 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
47 D A2,EXIT,^%ZISC
48 Q
49 ;
50START1 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
51 .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
52 .S CNTR=$G(CNTR)-1
53 .Q:CNTR=0
54 Q
55 ;
56EXIT K CNTR,CONV,COUNT,EX,I,J,N,P,PRCINDX,SEG,TDATE,X,XXZ,Y,Z11,^TMP($J,"PRCH516P")
57 Q
58 ;
59A2 ;Convert the vendor with intenal code 'Q'=158 to code 'S'=162 if code
60 ;'S' is not present. If code 'S' is present, just delete code 'Q' and
61 ;update the multiple header.
62 ;
63 S J="" F S J=$O(^TMP($J,"PRCH516P",J)) Q:J=""!(J'>0) D:$P($G(^TMP($J,"PRCH516P",J)),"^",1)=158
64 .S PRCINDX=$P(^PRC(440,J,1.1,0),"^",4)
65 .I PRCINDX>0 D
66 ..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
67 ..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
68 ..I $D(^PRC(440,J,1.1,162,0)) S $P(^PRC(440,J,1.1,0),"^",3)="162"
69 ;
70 ;Convert any vendor with code 'R'=159 to code 'RV'=167.
71 S J="" F S J=$O(^TMP($J,"PRCH516P",J)) Q:J=""!(J'>0) D:$P($G(^TMP($J,"PRCH516P",J)),"^",2)=159
72 .S PRCINDX=$P(^PRC(440,J,1.1,0),"^",4)
73 .I PRCINDX>0 D
74 ..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
75 ..;If code 'S' is not present, add it and update multiple header.
76 ..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
77 ..S $P(^PRC(440,J,1.1,0),"^",3)="167"
78 ..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
79 D A3
80 Q
81 ;
82A3 ;Get a record of vendors before and after conversion.
83 U IO
84 D NOW^%DTC S Y=% D DD^%DT S TDATE=Y
85 S (EX,P)=1,COUNT=0
86 I '$D(^TMP($J,"PRCH516P")) S P=1 D HEADER W !!!!!!,?10,"*** NO RECORDS TO PRINT ***" Q
87 ;
88 S J="" F S J=$O(^TMP($J,"PRCH516P",J)) Q:EX="^" Q:J=""!(J'>0) D
89 .D:P=1 HEADER
90 .S PRCINDX=$P(^PRC(440,J,1.1,0),"^",4) I PRCINDX>0 D
91 ..W ?2,J,?15,$P(^PRC(440,J,0),"^",1)
92 ..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)," "
93 ..W !
94 ..I (IOSL-$Y)<6 D HOLD Q:EX="^"
95 .S COUNT=COUNT+1
96 W !!,?5,"Found "_COUNT_" entries."
97 Q
98 ;
99HOLD ;
100 G HEADER:$P(IOST,"-")="P" W !,"Press return to continue, '^' to exit:" R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'["^" HEADER
101 Q
102HEADER ;
103 W @IOF
104 W !,"LIST OF VENDORS FOR PATCH PRC*5.1*16",?42,TDATE,?70,"PAGE ",P
105 W:$G(CONV)=1 !,"(AFTER CONVERSION)",!
106 W:$G(CONV)=0 !,"(BEFORE CONVERSION)",!
107 F I=1:1:8 W "----------"
108 W !,?2,"VENDOR ID",?15,"VENDOR NAME",?60,"VENDOR CODES",!!
109 S P=P+1
110 Q
111 ;
112A4 ;Allow the user to get a printout before conversion.
113 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
114 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
115 D A3,^%ZISC
116 Q
117 ;
118PRE ;Delete all the entries in file #420.6.
119 ;This entry point is invoked from KIDS for installation of PRC*5.1*16
120 ;and should not be used directly.
121 K ^PRCD(420.6)
122 Q
Note: See TracBrowser for help on using the repository browser.