ECXFEKEY ;BIR/DMA,CML-Print Feeder Keys; [ 05/15/96  9:44 AM ] ; 8/15/06 9:10am
 ;;3.0;DSS EXTRACTS;**10,11,8,40,84,92**;Dec 22, 1997;Build 30
EN ;entry point from option
 W !!,"Print list of Feeder Keys:",!
 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)
 S ECY=Y
 I ECY["2" D
 .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"
 .S DIR(0)="S^O:OLD;N:NEW",DIR("B")="NEW" D ^DIR K DIR Q:$D(DIRUT)  S ECECS=Y
 S:ECY["3" ECLAB=$$SELLABKE^ECXFEKE1() ;**Prompt to select Lab Feeder key
 G:($G(ECLAB)=-1) QUIT ;**GOTO Exit point
 G:$D(DIRUT) QUIT
 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS
 I POP W !,"NO DEVICE SELECTED!!" G QUIT
 I $D(IO("Q")) K IO("Q") D  G QUIT
 .S ZTRTN="START^ECXFEKEY",ZTDESC="Feeder Key List (DSS)"
 .S ZTSAVE("ECY")="",ZTSAVE("ECPHA")="",ZTSAVE("ECPHA2")="",ZTSAVE("ECECS")="",ZTSAVE("ECLAB")=""
 .D ^%ZTLOAD I $D(ZTSK) W !,"Queued Task #: "_ZTSK
 .D HOME^%ZIS K ZTSK
 ;
START ;queued entry point
 I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
 K ^TMP($J)
 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
 U IO D PRINT^ECXFEKE1
 Q
LAB S EC=0
 ;
 ;** OLD Feeder Key format
 I $G(ECLAB)="O" DO
 .F  S EC=$O(^LAB(60,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"LAB",EC,EC)=EC1
 ;
 ;** NEW Feeder key format (LMIP Code)
 I $G(ECLAB)="N" DO
 .N EC2
 .F  S EC=$O(^LAM(EC)) Q:'EC  DO
 ..I $D(^LAM(EC,0)) DO
 ...S EC1=$P(^LAM(EC,0),U,1),EC1=$P(EC1,"~",1)
 ...S EC2=$P(^LAM(EC,0),U,2)
 ...I EC2'[".9999",(EC2'[".8") S EC2=EC2\1
 ...S ^TMP($J,"LAB",+EC2,+EC2)=EC1
 Q
ECS ;old ECS feeder key list for pre-FY97 data
 G:$G(ECECS)="N" ECS2
 S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D  G ECQ
 .F  S EC=$O(^ECJ(EC)) Q:'EC  I $D(^(EC,0)) D
 ..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:"***")
 ..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")
 ..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")
 ..S ^TMP($J,"ECS",EC2_" - "_EC3,EC3)=EC4_" - "_EC5
 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
ECQ K EC1,EC2,EC3,EC4,EC5,EC6,EC7,EC8,EC9,EC10 Q
ECS2 ;new ECS feeder key list for FY97 data
 ;feeder key is <Procedure> if PCE CPT code is same or null;
 ;feeder is <Procedure-PCE CPT> otherwise;
 ;the description column of list shows procedure (EC5) in lowercase and CPT code (EC8) in uppercase;
 ;but if procedure (EC3) is itself a CPT Code, convert EC5 to uppercase
 ;concatenation of "A;" and "B;" are for proper sorting - CPT codes 1st, then other procedures
 S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D  G ECQ
 .F  S EC=$O(^ECJ(EC)) Q:'EC  I $D(^ECJ(EC,0)) D
 ..S EC1=$P($P(^ECJ(EC,0),U),"-",3,4)
 ..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")
 ..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")
 ..S EC5=$$LOW(EC5)
 ..I EC1["ICPT" S EC5=$$UPP(EC5),EC3="A;"_EC3
 ..S EC6=$P(EC1,"-",2),EC7="",EC8=""
 ..I EC6["EC(725," D
 ...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:"")
 ...S EC8=$S(+EC6>0:$E($P($G(^ICPT(+EC6,0)),U,2),1,25),1:"")
 ...S EC8=$$UPP(EC8),EC3="B;"_EC3
 ..S EC9=$S(EC7'="":EC3_"-"_EC7,1:EC3),EC10=$S(EC8'="":EC5_" - "_EC8,1:EC5)
 ..S ^TMP($J,"ECS",EC9,EC3)=EC10
 G ECQ
LOW(X) ;convert string to lowercase
 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)
 Q X
UPP(X) ;convert string to uppercase
 F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)
 Q X
 ;
PHA ;NEW PHA Feeder Key List sorted by NDF Match
 N ECPPDU,ECXPHA,ARRAY
 S ARRAY="^TMP($J,""ECXLIST"")"
 K @ARRAY
 ;Call pharmacy drug file (#50) api dbia 4483 and create ^TMP global
 D DATA^PSS50(,"??",DT,,,"ECXLIST")
 S ECXYM=$$ECXYM^ECXUTL(DT)
 ;$order thru "B" cross reference
 S ECD="" F  S ECD=$O(@ARRAY@("B",ECD)) Q:ECD=""  D
 .S EC=0 F  S EC=$O(@ARRAY@("B",ECD,EC)) Q:EC'>0  D
 ..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)
 ..S P1=$P(@ARRAY@(EC,20),U),P3=$P(@ARRAY@(EC,22),U)
 ..;get the 17 character key
 ..S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
 ..Q:+ECNFC=0
 ..S ECNFC="A"_ECNFC
 ..S ECPPDU=@ARRAY@(EC,16),ECPPDU=$FNUMBER(ECPPDU,"P",4)
 ..S ^TMP($J,"PHA",ECNFC,0)=ECD_U_ECPPDU
 K @ARRAY
 Q
CLI 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
 .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)
 .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)
 .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
 .I '$D(^ECX(728.44,SC,0)) S ECST=1,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3) Q
 .S EC=^ECX(728.44,SC,0),ECST=$P(EC,U,6)
 .I ECST=6 Q
 .;action code 6 means ignore
 .I $P(EC,U,4)]"" S ECSC=$P(EC,U,4)
 .I $P(EC,U,5)]"" S ECCSC=$P(EC,U,5)
 .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
 .I ECST<2 S P1=ECSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q
 .I ECST=2 S P1=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q
 .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
 .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)
 K ECLEN Q
RAD 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
 S ^TMP($J,"RAD",88888,88888)="Portable procedure",^TMP($J,"RAD",99999,99999)="OR procedure"
 Q
NUR 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
1 ;;PSI^PSYCHIATRIC
2 ;;SUR^SURGICAL
3 ;;MED^MEDICAL (EXCLUDE SCI)
4 ;;SCI^MEDICAL (SCI)
5 ;;NUR^NURSING HOME CARE UNIT
6 ;;REC^RECOVERY ROOM
7 ;;ITN^INTENSIVE CARE
8 ;;HEM^HEMODIALYSIS
9 ;;INT^INTERMEDIATE CARE
10 ;;DOM^DOMICILIARY
11 ;;ALC^ALCOHOL AND DRUG TREATMENT
 Q
NUT ;Feeder keys for Nutrition and Food Service extract
 N TYP,TIEN,DIET,IN,PRODUCT,KEY,NUMBER,IENS
 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
 . S IENS=""_IN_","_TIEN_","_""
 . S KEY=$$GET1^DIQ(728.451,IENS,1,"E")
 . S ^TMP($J,"ECX",KEY,DIET)=TYP_"  "_$$GET1^DIQ(728.451,IENS,.01,"E")
 Q
QUIT ;
 K ECY,ECPHA,ECECS,ECLAB,ECPPDU,DIR,DIRUT,DUOUT,X,Y
 Q