ECXFEKEY ;BIR/DMA,CML-Print Feeder Keys; [ 05/15/96 9:44 AM ] ;5/29/19 08:51
;;3.0;DSS EXTRACTS;**10,11,8,40,84,92,123,132,136,149,166,174**;Dec 22, 1997;Build 33
EN ;entry point from option
N ECXPORT,CNT,COL,LECOL,PCOL,PHATYPE,DIR,DIRUT,DTOUT,DUOUT,Y ;149,174
S ECXPORT=$$EXPORT Q:ECXPORT=-1 ;149
W !!,"Print list of Feeder Keys:",!
S DIR("?")=$S('$G(ECXPORT):"Select one or more feeder key systems to display",1:"Select one feeder key system to export") ;149
W !,"Select : 1. CLI",!,?9,"2. ECS",!,?9,"3. LAB",!,?9,"4. PHA",!,?9,"5. RAD",!,?9,"6. SUR",!,?9,"7. PRO",! S DIR(0)=$S('$G(ECXPORT):"L^1:7",1:"N^1:7:0") D ^DIR Q:$D(DIRUT) ;136,149 (removed NUT)
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
I ECY[4 D I $G(DIRUT) Q ;Section added in 174
.W !!,"The feeder key list for PHA can be printed by Drug, Non-Drug or both."
.S DIR(0)="S^D:Drugs;N:Non-Drugs;B:Both",DIR("B")="B"
.D ^DIR S PHATYPE=Y K DIR
I ECXPORT D Q ;Section added in 149
.K ^TMP($J),^TMP("ECXPORT",$J) ;Temp storage for results as regular report stores in ^TMP($J)
.W !!,"Gathering data for export..."
.S COL="FEEDER SYSTEM^FEEDER KEY^DESCRIPTION"
.S LECOL="SORT METHOD"_U_COL
.S PCOL=COL_U_"PRICE PER DISPENSE UNIT"_U_"TYPE" ;174
.S CNT=0
.D START
.M ^TMP($J,"ECXPORT")=^TMP("ECXPORT",$J) ;copy temp into exportable area
.D EXPDISP^ECXUTL1
.K ^TMP($J),^TMP("ECXPORT",$J)
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")="",ZTSAVE("PHATYPE")="" ;174
.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:'$G(ECXPORT) ^TMP($J) ;149
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 PHA D:EC=5 RAD D:EC=6 SUR^ECXFEKE1 D:EC=7 PRO ;136,149 Remove NUT
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($$CPT^ICPTCOD(+EC3),U,2),+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($$CPT^ICPTCOD(+EC5),U,3),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($$CPT^ICPTCOD(+EC3),U,2),+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($$CPT^ICPTCOD(+EC5),U,3),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($$CPT^ICPTCOD(+EC6),U,2),1:"")
...S EC8=$S(+EC6>0:$E($P($$CPT^ICPTCOD(+EC6),U,3),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,DEA,TYPE ;174
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)
..S DEA=@ARRAY@(EC,3) ;174 Get DEA value
..S TYPE=$S(DEA["S":"N",1:"D") ;174 Look at DEA to find supply (non-drug) items, all else are considered drugs
..I PHATYPE="N"&(TYPE="D") Q ;174 Don't count if item is a drug and we're looking for non-drug
..I PHATYPE="D"&(TYPE="N") Q ;174 Don't count if item is a non-drug and we're looking for drug
..;get the 17 character key
..S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
..I ECNFC="00000000000000000" S ECNFC="00000"_$S(TYPE="N":"LCL",1:"LCD")_$$RJ^XLFSTR($E(EC,$S($L(EC)'>9:1,1:1+($L(EC)-9)),$L(EC)),9,0) ;174
..S ECNFC=TYPE_ECNFC ;174 Force sorting order by type and then by key
..S ECPPDU=@ARRAY@(EC,16),ECPPDU=$FNUMBER(ECPPDU,"",4) ;174
..S ^TMP($J,"PHA",ECNFC,0)=ECD_U_ECPPDU_U_TYPE ;174 Add type for exporting
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"_P4,SC)=ECD ;166
.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",P4=$$GET1^DIQ(728.44,SC,13) 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 ;166
.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=$$GET1^DIQ(728.44,SC,7) S:P3="" P3="0000" S:ECCSC P2=$E("000"_ECCSC,$L(ECCSC)+1,$L(ECCSC)+3) Q ;166
.;I ECST<2 S P1=ECSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q ;166 dead code
.;I ECST=2 S P1=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q ;166 dead code
.;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 ;166 dead code
.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="0000" ;166
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
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
PRO ;Prosthetics Feeder Key section, API added in patch 136
N H,HCPCS,CODE,CPTNM,DESC,TYPE,SOURCE,LOC,FKEY,KEY
S H=0
F S H=$O(^ECX(727.826,H)) Q:+H<1 D
.S HCPCS=$P($G(^ECX(727.826,H,0)),U,33),KEY=$E($P($G(^ECX(727.826,H,0)),U,11),6,20)
.I HCPCS'="" I '$D(FKEY(HCPCS_KEY)) S FKEY(HCPCS_KEY)=HCPCS
S HCPCS="" F S HCPCS=$O(FKEY(HCPCS)) Q:HCPCS="" D
.S CODE=$$CPT^ICPTCOD(FKEY(HCPCS)) Q:+CODE=-1
.S CPTNM=HCPCS,DESC=$P(CODE,U,3)
.I $P(CODE,U,2)=""!(DESC="") Q
.S TYPE=$E(HCPCS,6),SOURCE=$E(HCPCS,7),LOC=$S(HCPCS["REQ":"REQ",HCPCS["REC":"REC",1:"")
.S DESC=DESC_$S(TYPE="R":"/Rent",TYPE="N":"/New",TYPE="X":"/Repair",1:"")_$S(SOURCE="V":"/VA",SOURCE="C":"/COM",1:"")_$S(LOC="REQ":"/XXX Site REQ",LOC="REC":"/XXX Site REC",1:"")
.S ^TMP($J,"PRO",CPTNM,CPTNM)=DESC
Q
QUIT ;
K ECY,ECPHA,ECECS,ECLAB,ECPPDU,DIR,DIRUT,DUOUT,X,Y
Q
EXPORT() ;Function indicates if report output is going to a device or to the screen in exportable format - API added in patch 149
N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,VAL
W !
S DIR("?",1)="Enter yes if you want the data to be displayed in an '^' delimited format",DIR("?")="that can be captured for exporting."
S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO",DIR("A")="Do you want the output in exportable format? "
D ^DIR
S VAL=$S($D(DIRUT):-1,Y="N":0,1:1)
I VAL=1 W !!,"Please select one feeder key system to display."
Q VAL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXFEKEY 10376 printed Dec 13, 2024@01:52:38 Page 2
ECXFEKEY ;BIR/DMA,CML-Print Feeder Keys; [ 05/15/96 9:44 AM ] ;5/29/19 08:51
+1 ;;3.0;DSS EXTRACTS;**10,11,8,40,84,92,123,132,136,149,166,174**;Dec 22, 1997;Build 33
EN ;entry point from option
+1 ;149,174
NEW ECXPORT,CNT,COL,LECOL,PCOL,PHATYPE,DIR,DIRUT,DTOUT,DUOUT,Y
+2 ;149
SET ECXPORT=$$EXPORT
if ECXPORT=-1
QUIT
+3 WRITE !!,"Print list of Feeder Keys:",!
+4 ;149
SET DIR("?")=$SELECT('$GET(ECXPORT):"Select one or more feeder key systems to display",1:"Select one feeder key system to export")
+5 ;136,149 (removed NUT)
WRITE !,"Select : 1. CLI",!,?9,"2. ECS",!,?9,"3. LAB",!,?9,"4. PHA",!,?9,"5. RAD",!,?9,"6. SUR",!,?9,"7. PRO",!
SET DIR(0)=$SELECT('$GET(ECXPORT):"L^1:7",1:"N^1:7:0")
DO ^DIR
if $DATA(DIRUT)
QUIT
+6 SET ECY=Y
+7 IF ECY["2"
Begin DoDot:1
+8 WRITE !!,"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 SET DIR(0)="S^O:OLD;N:NEW"
SET DIR("B")="NEW"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET ECECS=Y
End DoDot:1
+10 ;**Prompt to select Lab Feeder key
if ECY["3"
SET ECLAB=$$SELLABKE^ECXFEKE1()
+11 ;**GOTO Exit point
if ($GET(ECLAB)=-1)
GOTO QUIT
+12 if $DATA(DIRUT)
GOTO QUIT
+13 ;Section added in 174
IF ECY[4
Begin DoDot:1
+14 WRITE !!,"The feeder key list for PHA can be printed by Drug, Non-Drug or both."
+15 SET DIR(0)="S^D:Drugs;N:Non-Drugs;B:Both"
SET DIR("B")="B"
+16 DO ^DIR
SET PHATYPE=Y
KILL DIR
End DoDot:1
IF $GET(DIRUT)
QUIT
+17 ;Section added in 149
IF ECXPORT
Begin DoDot:1
+18 ;Temp storage for results as regular report stores in ^TMP($J)
KILL ^TMP($JOB),^TMP("ECXPORT",$JOB)
+19 WRITE !!,"Gathering data for export..."
+20 SET COL="FEEDER SYSTEM^FEEDER KEY^DESCRIPTION"
+21 SET LECOL="SORT METHOD"_U_COL
+22 ;174
SET PCOL=COL_U_"PRICE PER DISPENSE UNIT"_U_"TYPE"
+23 SET CNT=0
+24 DO START
+25 ;copy temp into exportable area
MERGE ^TMP($JOB,"ECXPORT")=^TMP("ECXPORT",$JOB)
+26 DO EXPDISP^ECXUTL1
+27 KILL ^TMP($JOB),^TMP("ECXPORT",$JOB)
End DoDot:1
QUIT
+28 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
+29 IF POP
WRITE !,"NO DEVICE SELECTED!!"
GOTO QUIT
+30 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+31 SET ZTRTN="START^ECXFEKEY"
SET ZTDESC="Feeder Key List (DSS)"
+32 ;174
SET ZTSAVE("ECY")=""
SET ZTSAVE("ECPHA")=""
SET ZTSAVE("ECPHA2")=""
SET ZTSAVE("ECECS")=""
SET ZTSAVE("ECLAB")=""
SET ZTSAVE("PHATYPE")=""
+33 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Queued Task #: "_ZTSK
+34 DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO QUIT
+35 ;
START ;queued entry point
+1 IF '$DATA(DT)
SET DT=$$HTFM^XLFDT(+$HOROLOG)
+2 ;149
if '$GET(ECXPORT)
KILL ^TMP($JOB)
+3 ;136,149 Remove NUT
FOR ECLIST=1:1
SET EC=$PIECE(ECY,",",ECLIST)
if EC=""
QUIT
if EC=1
DO CLI
if EC=2
DO ECS
if EC=3
DO LAB
if EC=4
DO PHA
if EC=5
DO RAD
if EC=6
DO SUR^ECXFEKE1
if EC=7
DO PRO
+4 USE IO
DO PRINT^ECXFEKE1
+5 QUIT
LAB SET EC=0
+1 ;
+2 ;** OLD Feeder Key format
+3 IF $GET(ECLAB)="O"
Begin DoDot:1
+4 FOR
SET EC=$ORDER(^LAB(60,EC))
if 'EC
QUIT
IF $DATA(^(EC,0))
SET EC1=$PIECE(^(0),U)
SET ^TMP($JOB,"LAB",EC,EC)=EC1
End DoDot:1
+5 ;
+6 ;** NEW Feeder key format (LMIP Code)
+7 IF $GET(ECLAB)="N"
Begin DoDot:1
+8 NEW EC2
+9 FOR
SET EC=$ORDER(^LAM(EC))
if 'EC
QUIT
Begin DoDot:2
+10 IF $DATA(^LAM(EC,0))
Begin DoDot:3
+11 SET EC1=$PIECE(^LAM(EC,0),U,1)
SET EC1=$PIECE(EC1,"~",1)
+12 SET EC2=$PIECE(^LAM(EC,0),U,2)
+13 IF EC2'[".9999"
IF (EC2'[".8")
SET EC2=EC2\1
+14 SET ^TMP($JOB,"LAB",+EC2,+EC2)=EC1
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
ECS ;old ECS feeder key list for pre-FY97 data
+1 if $GET(ECECS)="N"
GOTO ECS2
+2 SET EC=0
IF $PIECE($GET(^EC(720.1,1,0)),U,2)
Begin DoDot:1
+3 FOR
SET EC=$ORDER(^ECJ(EC))
if 'EC
QUIT
IF $DATA(^(EC,0))
Begin DoDot:2
+4 SET EC1=$PIECE($PIECE(^(0),U),"-",3,4)
SET EC2=$PIECE(EC1,"-")
SET EC2=$SELECT(+EC2:EC2,1:"***")
SET EC4=$SELECT($PIECE($GET(^EC(726,+EC2,0)),U)]"":$PIECE(^(0),U),1:"***")
+5 SET EC3=$PIECE(EC1,"-",2)
if '+EC3
QUIT
SET EC3=$SELECT(EC3["ICPT":$PIECE($$CPT^ICPTCOD(+EC3),U,2),+EC3<90000:$PIECE($GET(^EC(725,+EC3,0)),U,2)_"N",1:$PIECE($GET(^EC(725,+EC3,0)),U,2)_"L")
+6 SET EC5=$PIECE(EC1,"-",2)
SET EC5=$SELECT(EC5["ICPT":$EXTRACT($PIECE($$CPT^ICPTCOD(+EC5),U,3),1,25),EC5["EC":$EXTRACT($PIECE($GET(^EC(725,+EC5,0)),U),1,25),1:"UNKNOWN")
+7 SET ^TMP($JOB,"ECS",EC2_" - "_EC3,EC3)=EC4_" - "_EC5
End DoDot:2
End DoDot:1
GOTO ECQ
+8 FOR
SET EC=$ORDER(^ECK(EC))
if 'EC
QUIT
IF $DATA(^(EC,0))
SET EC1=$PIECE($PIECE(^(0),U),"-",3,4)
SET EC2=$EXTRACT($PIECE($GET(^ECP(+EC1,0)),U),1,25)
SET EC3=$EXTRACT($PIECE($GET(^ECP(+$PIECE(EC1,"-",2),0)),U),1,25)
SET ^TMP($JOB,"ECS",EC1,EC1)=EC2_" - "_EC3
ECQ KILL EC1,EC2,EC3,EC4,EC5,EC6,EC7,EC8,EC9,EC10
QUIT
ECS2 ;new ECS feeder key list for FY97 data
+1 ;feeder key is <Procedure> if PCE CPT code is same or null;
+2 ;feeder is <Procedure-PCE CPT> otherwise;
+3 ;the description column of list shows procedure (EC5) in lowercase and CPT code (EC8) in uppercase;
+4 ;but if procedure (EC3) is itself a CPT Code, convert EC5 to uppercase
+5 ;concatenation of "A;" and "B;" are for proper sorting - CPT codes 1st, then other procedures
+6 SET EC=0
IF $PIECE($GET(^EC(720.1,1,0)),U,2)
Begin DoDot:1
+7 FOR
SET EC=$ORDER(^ECJ(EC))
if 'EC
QUIT
IF $DATA(^ECJ(EC,0))
Begin DoDot:2
+8 SET EC1=$PIECE($PIECE(^ECJ(EC,0),U),"-",3,4)
+9 SET EC3=$PIECE(EC1,"-",2)
if '+EC3
QUIT
SET EC3=$SELECT(EC3["ICPT":$PIECE($$CPT^ICPTCOD(+EC3),U,2),+EC3<90000:$PIECE($GET(^EC(725,+EC3,0)),U,2)_"N",1:$PIECE($GET(^EC(725,+EC3,0)),U,2)_"L")
+10 SET EC5=$PIECE(EC1,"-",2)
SET EC5=$SELECT(EC5["ICPT":$EXTRACT($PIECE($$CPT^ICPTCOD(+EC5),U,3),1,25),EC5["EC":$EXTRACT($PIECE($GET(^EC(725,+EC5,0)),U),1,25),1:"UNKNOWN")
+11 SET EC5=$$LOW(EC5)
+12 IF EC1["ICPT"
SET EC5=$$UPP(EC5)
SET EC3="A;"_EC3
+13 SET EC6=$PIECE(EC1,"-",2)
SET EC7=""
SET EC8=""
+14 IF EC6["EC(725,"
Begin DoDot:3
+15 SET EC6=$SELECT(+EC6>0:$PIECE($GET(^EC(725,+EC6,0)),U,5),1:"")
SET EC7=$SELECT(+EC6>0:$PIECE($$CPT^ICPTCOD(+EC6),U,2),1:"")
+16 SET EC8=$SELECT(+EC6>0:$EXTRACT($PIECE($$CPT^ICPTCOD(+EC6),U,3),1,25),1:"")
+17 SET EC8=$$UPP(EC8)
SET EC3="B;"_EC3
End DoDot:3
+18 SET EC9=$SELECT(EC7'="":EC3_"-"_EC7,1:EC3)
SET EC10=$SELECT(EC8'="":EC5_" - "_EC8,1:EC5)
+19 SET ^TMP($JOB,"ECS",EC9,EC3)=EC10
End DoDot:2
End DoDot:1
GOTO ECQ
+20 GOTO ECQ
LOW(X) ;convert string to lowercase
+1 FOR %=2:1:$LENGTH(X)
IF $EXTRACT(X,%)?1U
IF $EXTRACT(X,%-1)?1A
SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)+32)_$EXTRACT(X,%+1,999)
+2 QUIT X
UPP(X) ;convert string to uppercase
+1 FOR %=1:1:$LENGTH(X)
if $EXTRACT(X,%)?1L
SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)-32)_$EXTRACT(X,%+1,999)
+2 QUIT X
+3 ;
PHA ;NEW PHA Feeder Key List sorted by NDF Match
+1 ;174
NEW ECPPDU,ECXPHA,ARRAY,DEA,TYPE
+2 SET ARRAY="^TMP($J,""ECXLIST"")"
+3 KILL @ARRAY
+4 ;Call pharmacy drug file (#50) api dbia 4483 and create ^TMP global
+5 DO DATA^PSS50(,"??",DT,,,"ECXLIST")
+6 SET ECXYM=$$ECXYM^ECXUTL(DT)
+7 ;$order thru "B" cross reference
+8 SET ECD=""
FOR
SET ECD=$ORDER(@ARRAY@("B",ECD))
if ECD=""
QUIT
Begin DoDot:1
+9 SET EC=0
FOR
SET EC=$ORDER(@ARRAY@("B",ECD,EC))
if EC'>0
QUIT
Begin DoDot:2
+10 SET ECD=$PIECE(@ARRAY@(EC,.01),U)
SET ECNDC=@ARRAY@(EC,31)
SET ECNFC=$$RJ^XLFSTR($PIECE(ECNDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",3),2,0)
SET ECNFC=$TRANSLATE(ECNFC,"*",0)
+11 SET P1=$PIECE(@ARRAY@(EC,20),U)
SET P3=$PIECE(@ARRAY@(EC,22),U)
+12 ;174 Get DEA value
SET DEA=@ARRAY@(EC,3)
+13 ;174 Look at DEA to find supply (non-drug) items, all else are considered drugs
SET TYPE=$SELECT(DEA["S":"N",1:"D")
+14 ;174 Don't count if item is a drug and we're looking for non-drug
IF PHATYPE="N"&(TYPE="D")
QUIT
+15 ;174 Don't count if item is a non-drug and we're looking for drug
IF PHATYPE="D"&(TYPE="N")
QUIT
+16 ;get the 17 character key
+17 SET ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
+18 ;174
IF ECNFC="00000000000000000"
SET ECNFC="00000"_$SELECT(TYPE="N":"LCL",1:"LCD")_$$RJ^XLFSTR($EXTRACT(EC,$SELECT($LENGTH(EC)'>9:1,1:1+($LENGTH(EC)-9)),$LENGTH(EC)),9,0)
+19 ;174 Force sorting order by type and then by key
SET ECNFC=TYPE_ECNFC
+20 ;174
SET ECPPDU=@ARRAY@(EC,16)
SET ECPPDU=$FNUMBER(ECPPDU,"",4)
+21 ;174 Add type for exporting
SET ^TMP($JOB,"PHA",ECNFC,0)=ECD_U_ECPPDU_U_TYPE
End DoDot:2
End DoDot:1
+22 KILL @ARRAY
+23 QUIT
CLI ;166
SET SC=0
FOR
SET SC=$ORDER(^SC(SC))
if 'SC
QUIT
IF $DATA(^(SC,0))
SET EC=^(0)
SET ECD=$PIECE(EC,U)
IF $PIECE(EC,U,3)="C"
Begin DoDot:1
+1 SET ECSC=$PIECE($GET(^DIC(40.7,+$PIECE(EC,U,7),0)),U,2)
SET ECCSC=$PIECE($GET(^DIC(40.7,+$PIECE(EC,U,18),0)),U,2)
+2 SET ECLEN="NNN"
IF $DATA(^SC(SC,"SL"))
IF $PIECE(^("SL"),U,2)'="V"
SET ECLEN=$SELECT($PIECE(^("SL"),U):$PIECE(^("SL"),U),1:"NNN")
SET ECLEN=$EXTRACT("000"_ECLEN,$LENGTH(ECLEN)+1,$LENGTH(ECLEN)+3)
+3 ;166
SET (P1,P2)="000"
SET P3="0000"
SET P4=$$GET1^DIQ(728.44,SC,13)
IF '$DATA(^ECX(728.44,SC,0))
IF ECCSC]""
SET ECST=5
SET P1=$EXTRACT("000"_ECSC,$LENGTH(ECSC)+1,$LENGTH(ECSC)+3)
SET P2=$EXTRACT("000"_ECCSC,$LENGTH(ECCSC)+1,$LENGTH(ECCSC)+3)
QUIT
+4 IF '$DATA(^ECX(728.44,SC,0))
SET ECST=1
SET P1=$EXTRACT("000"_ECSC,$LENGTH(ECSC)+1,$LENGTH(ECSC)+3)
QUIT
+5 SET EC=^ECX(728.44,SC,0)
SET ECST=$PIECE(EC,U,6)
+6 IF ECST=6
QUIT
+7 ;action code 6 means ignore
+8 IF $PIECE(EC,U,4)]""
SET ECSC=$PIECE(EC,U,4)
+9 IF $PIECE(EC,U,5)]""
SET ECCSC=$PIECE(EC,U,5)
+10 ;166
IF ECST=""
SET ECST=4
SET P1=$EXTRACT("000"_ECSC,$LENGTH(ECSC)+1,$LENGTH(ECSC)+3)
SET P3=$$GET1^DIQ(728.44,SC,7)
if P3=""
SET P3="0000"
if ECCSC
SET P2=$EXTRACT("000"_ECCSC,$LENGTH(ECCSC)+1,$LENGTH(ECCSC)+3)
QUIT
+11 ;I ECST<2 S P1=ECSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q ;166 dead code
+12 ;I ECST=2 S P1=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q ;166 dead code
+13 ;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 ;166 dead code
+14 ;166
IF ECST>3
IF ECST<7
SET P1=ECSC
SET P2=ECCSC
SET P1=$EXTRACT("000"_P1,$LENGTH(P1)+1,$LENGTH(P1)+3)
SET P2=$EXTRACT("000"_P2,$LENGTH(P2)+1,$LENGTH(P2)+3)
if ECST=4
SET P3=$PIECE($GET(^ECX(728.441,+$PIECE(^ECX(728.44,SC,0),U,8),0)),U)
IF P3=""
SET P3="0000"
End DoDot:1
SET ^TMP($JOB,"CLI","A;"_P1_P2_ECLEN_P3_"0"_P4,SC)=ECD
+15 KILL ECLEN
QUIT
RAD SET EC=0
FOR
SET EC=$ORDER(^RAMIS(71,EC))
if 'EC
QUIT
IF $DATA(^(EC,0))
SET EC1=^(0)
SET ECD=$PIECE(EC1,U)
SET EC2=$PIECE($GET(^ICPT(+$PIECE(EC1,U,9),0)),U)
if EC2=""
SET EC2="Unknown"
SET ^TMP($JOB,"RAD",EC2,EC)=ECD
+1 SET ^TMP($JOB,"RAD",88888,88888)="Portable procedure"
SET ^TMP($JOB,"RAD",99999,99999)="OR procedure"
+2 QUIT
NUT ;Feeder keys for Nutrition and Food Service extract
+1 NEW TYP,TIEN,DIET,IN,PRODUCT,KEY,NUMBER,IENS
+2 SET TYP=""
FOR
SET TYP=$ORDER(^ECX(728.45,"B",TYP))
if TYP=""
QUIT
SET TIEN=0
FOR
SET TIEN=$ORDER(^ECX(728.45,"B",TYP,TIEN))
if 'TIEN
QUIT
SET DIET=""
FOR
SET DIET=$ORDER(^ECX(728.45,TIEN,1,"B",DIET))
if DIET=""
QUIT
SET IN=0
FOR
SET IN=$ORDER(^ECX(728.45,TIEN,1,"B",DIET,IN))
if IN'>0
QUIT
Begin DoDot:1
+3 SET IENS=""_IN_","_TIEN_","_""
+4 SET KEY=$$GET1^DIQ(728.451,IENS,1,"E")
+5 SET ^TMP($JOB,"ECX",KEY,DIET)=TYP_" "_$$GET1^DIQ(728.451,IENS,.01,"E")
End DoDot:1
+6 QUIT
PRO ;Prosthetics Feeder Key section, API added in patch 136
+1 NEW H,HCPCS,CODE,CPTNM,DESC,TYPE,SOURCE,LOC,FKEY,KEY
+2 SET H=0
+3 FOR
SET H=$ORDER(^ECX(727.826,H))
if +H<1
QUIT
Begin DoDot:1
+4 SET HCPCS=$PIECE($GET(^ECX(727.826,H,0)),U,33)
SET KEY=$EXTRACT($PIECE($GET(^ECX(727.826,H,0)),U,11),6,20)
+5 IF HCPCS'=""
IF '$DATA(FKEY(HCPCS_KEY))
SET FKEY(HCPCS_KEY)=HCPCS
End DoDot:1
+6 SET HCPCS=""
FOR
SET HCPCS=$ORDER(FKEY(HCPCS))
if HCPCS=""
QUIT
Begin DoDot:1
+7 SET CODE=$$CPT^ICPTCOD(FKEY(HCPCS))
if +CODE=-1
QUIT
+8 SET CPTNM=HCPCS
SET DESC=$PIECE(CODE,U,3)
+9 IF $PIECE(CODE,U,2)=""!(DESC="")
QUIT
+10 SET TYPE=$EXTRACT(HCPCS,6)
SET SOURCE=$EXTRACT(HCPCS,7)
SET LOC=$SELECT(HCPCS["REQ":"REQ",HCPCS["REC":"REC",1:"")
+11 SET DESC=DESC_$SELECT(TYPE="R":"/Rent",TYPE="N":"/New",TYPE="X":"/Repair",1:"")_$SELECT(SOURCE="V":"/VA",SOURCE="C":"/COM",1:"")_$SELECT(LOC="REQ":"/XXX Site REQ",LOC="REC":"/XXX Site REC",1:"")
+12 SET ^TMP($JOB,"PRO",CPTNM,CPTNM)=DESC
End DoDot:1
+13 QUIT
QUIT ;
+1 KILL ECY,ECPHA,ECECS,ECLAB,ECPPDU,DIR,DIRUT,DUOUT,X,Y
+2 QUIT
EXPORT() ;Function indicates if report output is going to a device or to the screen in exportable format - API added in patch 149
+1 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,VAL
+2 WRITE !
+3 SET DIR("?",1)="Enter yes if you want the data to be displayed in an '^' delimited format"
SET DIR("?")="that can be captured for exporting."
+4 SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="NO"
SET DIR("A")="Do you want the output in exportable format? "
+5 DO ^DIR
+6 SET VAL=$SELECT($DATA(DIRUT):-1,Y="N":0,1:1)
+7 IF VAL=1
WRITE !!,"Please select one feeder key system to display."
+8 QUIT VAL
+9 ;
