source: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXFEKEY.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1ECXFEKEY ;BIR/DMA,CML-Print Feeder Keys; [ 05/15/96 9:44 AM ] ; 8/15/06 9:10am
2 ;;3.0;DSS EXTRACTS;**10,11,8,40,84,92**;Dec 22, 1997;Build 30
3EN ;entry point from option
4 W !!,"Print list of Feeder Keys:",!
5 W !,"Select : 1. CLI",!,?9,"2. ECS",!,?9,"3. LAB",!,?9,"4. NUR",!,?9,"5. NUT",!,?9,"6. PHA",!,?9,"7. RAD",!,?9,"8. SUR",! S DIR(0)="L^1:8" D ^DIR Q:$D(DIRUT)
6 S ECY=Y
7 I ECY["2" D
8 .W !!,"The Feeder Key List for the Feeder System ECS can be printed by:",!?5,"(O)ld Feeder Key sort by Category-Procedure",!?5,"(N)ew Feeder Key sort by Procedure-CPT Code"
9 .S DIR(0)="S^O:OLD;N:NEW",DIR("B")="NEW" D ^DIR K DIR Q:$D(DIRUT) S ECECS=Y
10 S:ECY["3" ECLAB=$$SELLABKE^ECXFEKE1() ;**Prompt to select Lab Feeder key
11 G:($G(ECLAB)=-1) QUIT ;**GOTO Exit point
12 G:$D(DIRUT) QUIT
13 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS
14 I POP W !,"NO DEVICE SELECTED!!" G QUIT
15 I $D(IO("Q")) K IO("Q") D G QUIT
16 .S ZTRTN="START^ECXFEKEY",ZTDESC="Feeder Key List (DSS)"
17 .S ZTSAVE("ECY")="",ZTSAVE("ECPHA")="",ZTSAVE("ECPHA2")="",ZTSAVE("ECECS")="",ZTSAVE("ECLAB")=""
18 .D ^%ZTLOAD I $D(ZTSK) W !,"Queued Task #: "_ZTSK
19 .D HOME^%ZIS K ZTSK
20 ;
21START ;queued entry point
22 I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
23 K ^TMP($J)
24 F ECLIST=1:1 S EC=$P(ECY,",",ECLIST) Q:EC="" D:EC=1 CLI D:EC=2 ECS D:EC=3 LAB D:EC=4 NUR D:EC=5 NUT D:EC=6 PHA D:EC=7 RAD D:EC=8 SUR^ECXFEKE1
25 U IO D PRINT^ECXFEKE1
26 Q
27LAB S EC=0
28 ;
29 ;** OLD Feeder Key format
30 I $G(ECLAB)="O" DO
31 .F S EC=$O(^LAB(60,EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"LAB",EC,EC)=EC1
32 ;
33 ;** NEW Feeder key format (LMIP Code)
34 I $G(ECLAB)="N" DO
35 .N EC2
36 .F S EC=$O(^LAM(EC)) Q:'EC DO
37 ..I $D(^LAM(EC,0)) DO
38 ...S EC1=$P(^LAM(EC,0),U,1),EC1=$P(EC1,"~",1)
39 ...S EC2=$P(^LAM(EC,0),U,2)
40 ...I EC2'[".9999",(EC2'[".8") S EC2=EC2\1
41 ...S ^TMP($J,"LAB",+EC2,+EC2)=EC1
42 Q
43ECS ;old ECS feeder key list for pre-FY97 data
44 G:$G(ECECS)="N" ECS2
45 S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G ECQ
46 .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^(EC,0)) D
47 ..S EC1=$P($P(^(0),U),"-",3,4),EC2=$P(EC1,"-"),EC2=$S(+EC2:EC2,1:"***"),EC4=$S($P($G(^EC(726,+EC2,0)),U)]"":$P(^(0),U),1:"***")
48 ..S EC3=$P(EC1,"-",2) Q:'+EC3 S EC3=$S(EC3["ICPT":$P($G(^ICPT(+EC3,0)),U),+EC3<90000:$P($G(^EC(725,+EC3,0)),U,2)_"N",1:$P($G(^EC(725,+EC3,0)),U,2)_"L")
49 ..S EC5=$P(EC1,"-",2),EC5=$S(EC5["ICPT":$E($P($G(^ICPT(+EC5,0)),U,2),1,25),EC5["EC":$E($P($G(^EC(725,+EC5,0)),U),1,25),1:"UNKNOWN")
50 ..S ^TMP($J,"ECS",EC2_" - "_EC3,EC3)=EC4_" - "_EC5
51 F S EC=$O(^ECK(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P($P(^(0),U),"-",3,4),EC2=$E($P($G(^ECP(+EC1,0)),U),1,25),EC3=$E($P($G(^ECP(+$P(EC1,"-",2),0)),U),1,25),^TMP($J,"ECS",EC1,EC1)=EC2_" - "_EC3
52ECQ K EC1,EC2,EC3,EC4,EC5,EC6,EC7,EC8,EC9,EC10 Q
53ECS2 ;new ECS feeder key list for FY97 data
54 ;feeder key is <Procedure> if PCE CPT code is same or null;
55 ;feeder is <Procedure-PCE CPT> otherwise;
56 ;the description column of list shows procedure (EC5) in lowercase and CPT code (EC8) in uppercase;
57 ;but if procedure (EC3) is itself a CPT Code, convert EC5 to uppercase
58 ;concatenation of "A;" and "B;" are for proper sorting - CPT codes 1st, then other procedures
59 S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G ECQ
60 .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^ECJ(EC,0)) D
61 ..S EC1=$P($P(^ECJ(EC,0),U),"-",3,4)
62 ..S EC3=$P(EC1,"-",2) Q:'+EC3 S EC3=$S(EC3["ICPT":$P($G(^ICPT(+EC3,0)),U),+EC3<90000:$P($G(^EC(725,+EC3,0)),U,2)_"N",1:$P($G(^EC(725,+EC3,0)),U,2)_"L")
63 ..S EC5=$P(EC1,"-",2),EC5=$S(EC5["ICPT":$E($P($G(^ICPT(+EC5,0)),U,2),1,25),EC5["EC":$E($P($G(^EC(725,+EC5,0)),U),1,25),1:"UNKNOWN")
64 ..S EC5=$$LOW(EC5)
65 ..I EC1["ICPT" S EC5=$$UPP(EC5),EC3="A;"_EC3
66 ..S EC6=$P(EC1,"-",2),EC7="",EC8=""
67 ..I EC6["EC(725," D
68 ...S EC6=$S(+EC6>0:$P($G(^EC(725,+EC6,0)),U,5),1:"") S EC7=$S(+EC6>0:$P($G(^ICPT(+EC6,0)),U),1:"")
69 ...S EC8=$S(+EC6>0:$E($P($G(^ICPT(+EC6,0)),U,2),1,25),1:"")
70 ...S EC8=$$UPP(EC8),EC3="B;"_EC3
71 ..S EC9=$S(EC7'="":EC3_"-"_EC7,1:EC3),EC10=$S(EC8'="":EC5_" - "_EC8,1:EC5)
72 ..S ^TMP($J,"ECS",EC9,EC3)=EC10
73 G ECQ
74LOW(X) ;convert string to lowercase
75 F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)
76 Q X
77UPP(X) ;convert string to uppercase
78 F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)
79 Q X
80 ;
81PHA ;NEW PHA Feeder Key List sorted by NDF Match
82 N ECPPDU,ECXPHA,ARRAY
83 S ARRAY="^TMP($J,""ECXLIST"")"
84 K @ARRAY
85 ;Call pharmacy drug file (#50) api dbia 4483 and create ^TMP global
86 D DATA^PSS50(,"??",DT,,,"ECXLIST")
87 S ECXYM=$$ECXYM^ECXUTL(DT)
88 ;$order thru "B" cross reference
89 S ECD="" F S ECD=$O(@ARRAY@("B",ECD)) Q:ECD="" D
90 .S EC=0 F S EC=$O(@ARRAY@("B",ECD,EC)) Q:EC'>0 D
91 ..S ECD=$P(@ARRAY@(EC,.01),U),ECNDC=@ARRAY@(EC,31),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
92 ..S P1=$P(@ARRAY@(EC,20),U),P3=$P(@ARRAY@(EC,22),U)
93 ..;get the 17 character key
94 ..S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
95 ..Q:+ECNFC=0
96 ..S ECNFC="A"_ECNFC
97 ..S ECPPDU=@ARRAY@(EC,16),ECPPDU=$FNUMBER(ECPPDU,"P",4)
98 ..S ^TMP($J,"PHA",ECNFC,0)=ECD_U_ECPPDU
99 K @ARRAY
100 Q
101CLI S SC=0 F S SC=$O(^SC(SC)) Q:'SC I $D(^(SC,0)) S EC=^(0),ECD=$P(EC,U) I $P(EC,U,3)="C" D S ^TMP($J,"CLI","A;"_P1_P2_ECLEN_P3_"0",SC)=ECD
102 .S ECSC=$P($G(^DIC(40.7,+$P(EC,U,7),0)),U,2),ECCSC=$P($G(^DIC(40.7,+$P(EC,U,18),0)),U,2)
103 .S ECLEN="NNN" I $D(^SC(SC,"SL")),$P(^("SL"),U,2)'="V" S ECLEN=$S($P(^("SL"),U):$P(^("SL"),U),1:"NNN"),ECLEN=$E("000"_ECLEN,$L(ECLEN)+1,$L(ECLEN)+3)
104 .S (P1,P2)="000",P3="0000" I '$D(^ECX(728.44,SC,0)),ECCSC]"" S ECST=5,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3),P2=$E("000"_ECCSC,$L(ECCSC)+1,$L(ECCSC)+3) Q
105 .I '$D(^ECX(728.44,SC,0)) S ECST=1,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3) Q
106 .S EC=^ECX(728.44,SC,0),ECST=$P(EC,U,6)
107 .I ECST=6 Q
108 .;action code 6 means ignore
109 .I $P(EC,U,4)]"" S ECSC=$P(EC,U,4)
110 .I $P(EC,U,5)]"" S ECCSC=$P(EC,U,5)
111 .I ECST="" S ECST=4,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3),P3=$E("0000"_SC,$L(SC)+1,$L(SC)+4) S:ECCSC P2=$E("000"_ECCSC,$L(ECCSC)+1,$L(ECCSC)+3) Q
112 .I ECST<2 S P1=ECSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q
113 .I ECST=2 S P1=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q
114 .I ECST=3 S P1=ECSC,P11=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3),P11=$E("000"_P11,$L(P11)+1,$L(P11)+3) Q
115 .I ECST>3,ECST<7 S P1=ECSC,P2=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3),P2=$E("000"_P2,$L(P2)+1,$L(P2)+3) S:ECST=4 P3=$P($G(^ECX(728.441,+$P(^ECX(728.44,SC,0),U,8),0)),U) I P3="" S P3=$E("0000"_SC,$L(SC)+1,$L(SC)+4)
116 K ECLEN Q
117RAD S EC=0 F S EC=$O(^RAMIS(71,EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),ECD=$P(EC1,U),EC2=$P($G(^ICPT(+$P(EC1,U,9),0)),U) S:EC2="" EC2="Unknown" S ^TMP($J,"RAD",EC2,EC)=ECD
118 S ^TMP($J,"RAD",88888,88888)="Portable procedure",^TMP($J,"RAD",99999,99999)="OR procedure"
119 Q
120NUR F EC=1:1:11 S EC1=$P($T(@EC),";",3) F EC2=0:1:5 S ^TMP($J,"NUR",$P(EC1,U)_"-"_EC2,EC2)=$P(EC1,U,2)_" LEVEL "_EC2
1211 ;;PSI^PSYCHIATRIC
1222 ;;SUR^SURGICAL
1233 ;;MED^MEDICAL (EXCLUDE SCI)
1244 ;;SCI^MEDICAL (SCI)
1255 ;;NUR^NURSING HOME CARE UNIT
1266 ;;REC^RECOVERY ROOM
1277 ;;ITN^INTENSIVE CARE
1288 ;;HEM^HEMODIALYSIS
1299 ;;INT^INTERMEDIATE CARE
13010 ;;DOM^DOMICILIARY
13111 ;;ALC^ALCOHOL AND DRUG TREATMENT
132 Q
133NUT ;Feeder keys for Nutrition and Food Service extract
134 N TYP,TIEN,DIET,IN,PRODUCT,KEY,NUMBER,IENS
135 S TYP="" F S TYP=$O(^ECX(728.45,"B",TYP)) Q:TYP="" S TIEN=0 F S TIEN=$O(^ECX(728.45,"B",TYP,TIEN)) Q:'TIEN S DIET="" F S DIET=$O(^ECX(728.45,TIEN,1,"B",DIET)) Q:DIET="" S IN=0 F S IN=$O(^ECX(728.45,TIEN,1,"B",DIET,IN)) Q:IN'>0 D
136 . S IENS=""_IN_","_TIEN_","_""
137 . S KEY=$$GET1^DIQ(728.451,IENS,1,"E")
138 . S ^TMP($J,"ECX",KEY,DIET)=TYP_" "_$$GET1^DIQ(728.451,IENS,.01,"E")
139 Q
140QUIT ;
141 K ECY,ECPHA,ECECS,ECLAB,ECPPDU,DIR,DIRUT,DUOUT,X,Y
142 Q
Note: See TracBrowser for help on using the repository browser.