ECXFELOC.m

ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96  8:41 AM ] ;5/20/19  11:24

 ;;3.0;DSS EXTRACTS;**1,8,105,132,136,149,174**;Dec 22, 1997;Build 33

EN ;entry point from option

 W !!,"Print list of feeder locations.",! S QFLG=1

 N ECXPORT,CNT,DIR,X,Y,DTOUT,DUOUT,ZTDESC,ZTRTN,ZTSAVE,ECY,SIEN,DIRUT ;149,174

 S DIR("?")="Select one or more feeder key systems to display" ;174

 S DIR("A")="Enter a list or range of numbers (1-9) or hit enter for all: ",DIR("B")="1-9" ;174

 W !,"Select : 1. CLI",!,?9,"2. ECS",!,?9,"3. IVP",!,?9,"4. LAB",!,?9,"5. PRE",!,?9,"6. PRO",!,?9,"7. RAD",!,?9,"8. SUR",!,?9,"9. UDP",! S DIR(0)="LA^1:9" D ^DIR Q:$D(DIRUT)  ;136,149,174

 K DIR S ECY=Y ;174

 S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1  ;149

 I $G(ECXPORT) D  Q  ;Section added in 149

 .K ^TMP($J)

 .S ^TMP($J,"ECXPORT",0)="FEEDER SYSTEM^FEEDER LOCATION^DIVISION^DESCRIPTION",CNT=1 ;174

 .D START

 .D EXPDISP^ECXUTL1

 K %ZIS S %ZIS="Q" D ^%ZIS Q:POP 

 I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC",ZTSAVE("ECY")="" D ^%ZTLOAD D ^%ZISC G OUT ;174

START ;queued entry point

 N ECLIST,EC ;174

 I '$D(DT) S DT=$$HTFM^XLFDT(+$H)

 K:'$G(ECXPORT) ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)="" ;149

 F ECLIST=1:1 S EC=$P(ECY,",",ECLIST) Q:EC=""  D:EC=1 CLI D:EC=2 ECS D:EC=3 IV D:EC=4 LAB D:EC=5 PRE D:EC=6 PRO D:EC=7 RAD D:EC=8 SUR D:EC=9 UDP ;174

 U IO D PRINT ;174

 Q  ;174

LAB S EC=0 F  S EC=$O(^LRO(68,EC)) Q:'EC  S SIEN=0 F  S SIEN=$O(^LRO(68,EC,3,SIEN)) Q:'+SIEN  S EC1=$G(^LRO(68,EC,0)),^TMP($J,"LAB",$P(EC1,U,11),EC)=$$RADDIV^ECXDEPT($P(^LRO(68,EC,3,SIEN,0),U))_U_$P(EC1,U) ;174

 Q  ;174

ECS S EC=0 F  S EC=$O(^ECJ(EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=$$RADDIV^ECXDEPT($P(EC1,"-"))_U_EC2 ;174

 F  S EC=$O(^ECK(EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2

 Q  ;174

IV S EC=0 F  S EC=$O(^DG(40.8,EC)) Q:'EC  I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"IVP","IVP"_EC,EC)=$$GETDIV^ECXDEPT(EC)_U_"IV Pharmacy-"_EC1 ;174

 Q  ;174

CLI S EC=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D

 .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RD<DT)) S ^TMP($J,"CLI",ECS_ECSC,EC)=$$GETDIV^ECXDEPT(ECS)_U_ECD ;174

 Q  ;174

PRE N ARRAY S ARRAY="^TMP($J,""ECXDSS"")" K @ARRAY D PSS^PSO59(,"??","ECXDSS") I @ARRAY@(0)>0 G V6

 ;dbia (#4689)

 S EC=0 F  S EC=$O(^DIC(59,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1

 Q  ;174

V6 S EC=0 F  S EC=$O(@ARRAY@(EC)) Q:'EC  I $D(^(EC)) S EC1=$E(@ARRAY@(EC,.01),1,30),^TMP($J,"PRE","PRE"_EC,EC)=$G(@ARRAY@(EC,.06))_U_"Prescriptions-"_EC1 ;174

 K @ARRAY

 Q  ;174

RAD S EC=0 F  S EC=$O(^RA(79,EC)),EC1=0 Q:'EC  I $D(^(EC,0)) S ECD=$P(^(0),U) F  S EC1=$O(^RA(79.2,EC1)) Q:'EC1  I $D(^(EC1,0)) S ECD1=$P(^(0),U),^TMP($J,"RAD",EC_"-"_EC1,EC_"-"_EC1)=$$RADDIV^ECXDEPT(ECD)_U_ECD_"-"_ECD1 ;174

 Q  ;174

NUR ;S EC=0 F  S EC=$O(^NURSF(211.4,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1 ;132

 Q  ;174

SUR ;174, Updated surgery section

 N J,X,DIV,EC,EC31,ECF1,ECFL,ECFLX,ECFX,F1,F1SUB,F1NM,F2,F2SUB,F2NM,FL

 K ^TMP($J,"ECXAUD")

 ;setup array of feeder location names

 F F1=1:1:14 S X=$P($T(FEED1+F1),";",3),F1SUB=$P(X,U,1),F1NM=$P(X,U,2) S ^TMP($J,"ECXFL","OR"_F1SUB)=F1NM D

 .F F2=1:1:7 S X=$P($T(FEED2+F2),";",3),F2SUB=$P(X,U,1),F2NM=$P(X,U,2) S ^TMP($J,"ECXFL","OR"_F1SUB_F2SUB)=F1NM_" - "_F2NM,FL(F2SUB)=F2NM

 ;process extract records

 ;type='p'rimary or 's'econdary or 'i'mplant

 ;ignore type=secondary

 S J=0 F  S J=$O(^ECX(727.811,J)) Q:'J  I $D(^ECX(727.811,J,0)) S EC=^(0),DIV=$P(EC,U,4) I $P(EC,U,17)'="S",$P(EC,U,28)'="C" D

 .;determine feeder location

 .S ECF1=$E($P(EC,U,32),1,4)

 .I ECF1="" D

 ..S ECF1=$P(EC,U,30),ECF1="OR"_$E("GEORCANECNAMINENCYWACLDEOT",ECF1*2-1,ECF1*2)

 ..S:ECF1="OR" ECF1="ORNO"

 ..I $P(EC,U,30)="",$P(EC,U,12)="",$P(EC,U,11)="059" S ECF1="ORCY"

 .S ECFL=DIV_ECF1

 .;type=implant generates one product record; volume is always at least 1

 .I $P(EC,U,17)="I" D  Q

 ..S ECFLX=ECFL_"I"

 ..S ^TMP($J,"SUR",ECFLX,ECFLX)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1_"I"))'="":^TMP($J,"ECXFL",ECF1_"I"),1:"NON-OR"_" - "_$G(FL("I")))

 .;type=primary generates four or five product records, but only two are of interest here

 .;anesthesia time product

 .S ECQ=+$P(EC,U,22) I ECQ>0 D

 ..S ECFLX=ECFL_"A"

 ..S ^TMP($J,"SUR",ECFLX,ECFLX)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1_"A"))'="":^TMP($J,"ECXFL",ECF1_"A"),1:"NON-OR"_" - "_$G(FL("A")))

 .;surgeon time product

 .S ECQ=+$P(EC,U,21) I ECQ>0 D

 ..S EC31=+$P(EC,U,31),ECFX=$S(EC31=10:"D",EC31=24:"M",EC31=32:"P",EC31=43:"C",1:"S")

 ..S ECFLX=ECFL_ECFX

 ..S ^TMP($J,"SUR",ECFLX,ECFLX)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1_ECFX))'="":^TMP($J,"ECXFL",ECF1_ECFX),1:"NON-OR"_" - "_$G(FL(ECFX)))

 .;patient time product

 .S ECQ=+$P(EC,U,20) I ECQ>0 D

 ..S ^TMP($J,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1))'="":^TMP($J,"ECXFL",ECF1),1:"NON-OR")

 .;recovery room time product only if not cystoscopy and not non-or

 .I ECFL'="ORCY",$P(EC,U,32)="" D

 ..S ECQ=+$P(EC,U,33) I ECQ>0 D

 ...S ^TMP($J,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1))'="":^TMP($J,"ECXFL",ECF1),1:"NON-OR")

 .;technician time product, only for cystoscopy

 .I ECFL="ORCY" D

 ..S ECQ=+$P(EC,U,20) S:($P(EC,U,22)>$P(EC,U,20)) ECQ=+$P(EC,U,22) I ECQ>0 D

 ...S ^TMP($J,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1))'="":^TMP($J,"ECXFL",ECF1),1:"NON-OR")

 .S ^TMP($J,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$S($G(^TMP($J,"ECXFL",ECF1))'="":^TMP($J,"ECXFL",ECF1),1:"NON-OR")

 K ^TMP($J,"ECXFL")

 Q

 ;

UDP S EC=0 F  S EC=$O(^DG(40.8,EC)) Q:'EC  I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"UDP","UDP"_EC,EC)=$$GETDIV^ECXDEPT(EC)_U_"Unit Dose Medications-"_EC1 ;174

 Q  ;174

DEN ;S EC=0 F  S EC=$O(^DENT(225,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"DEN",EC1,EC)="Dental "_EC1

PRO ;Prosthetics Location Information. API added in patch 136

 N IEN,LOC,DIV,X,ORDER

 S IEN=0 F  S IEN=$O(^ECX(727.826,IEN)) Q:'+IEN  S LOC=$P($G(^ECX(727.826,IEN,0)),U,10) I LOC'="" S:'$D(LOC(LOC)) LOC(LOC)=""

 S LOC="" F  S LOC=$O(LOC(LOC)) Q:LOC=""  D

 .S DIV=$P(LOC,$S(LOC["NONL":"NONL",LOC["ORD":"ORD",LOC["HO2":"HO2",LOC["LAB":"LAB",1:""),1) I DIV="" S DIV=+LOC

 .S DIC=4,DIC(0)="MXQ",X=DIV D ^DIC Q:Y=-1

 .S ORDER=$P(LOC,DIV,2)

 .S ^TMP($J,"PRO",LOC,LOC)=$$RADDIV^ECXDEPT(DIV)_U_$P(Y,U,2)_" "_$S(ORDER="HO2":"Home Oxygen",ORDER="NONL":"Non Lab Location",ORDER="LAB":"Prosthetics Lab",ORDER="ORD":"Ordering Location",1:"") ;174

 Q  ;174

 ;

PRINT ;

 S EC="" F  S EC=$O(^TMP($J,EC)),EC1="" Q:EC=""  Q:QFLG  D:'$G(ECXPORT) HEAD Q:QFLG  F  S EC1=$O(^TMP($J,EC,EC1)),EC2=""  Q:EC1=""  Q:QFLG  F  S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2=""  Q:QFLG  D  ;149

 .I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=EC_U_EC1_U_^(EC2),CNT=CNT+1 Q  ;149

 .W !,EC1,?18,$P(^(EC2),U),?28,$P(^(EC2),U,2) I $Y+3>IOSL D HEAD Q:QFLG  ;174

OUT I '$G(ECXPORT) I $E(IOST)="C"&('QFLG) S DIR(0)="E" D  D ^DIR K DIR ;149

 .S SS=22-$Y F JJ=1:1:SS W !

 K:'$G(ECXPORT) ^TMP($J) K DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y ;149

 I '$G(ECXPORT) W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q  ;149

 Q  ;149

HEAD ;

 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !

 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q

 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,?15,"Feeder Location List For Feeder System ",EC,?70,"Page: ",PG,!!,"FEEDER LOCATION",?18,"DIVISION",?28,"DESCRIPTION",!,LN ;174

 Q

 ;

FEED1 ;or location names

 ;;AM^AMBULATORY OR

 ;;CA^CARDIAC OR

 ;;CL^CLINIC

 ;;CN^CARDIAC/NEURO OR

 ;;CY^CYSTOSCOPY RM.

 ;;DE^DEDICATED RM.

 ;;EN^ENDOSCOPY RM.

 ;;GE^GENERAL OR

 ;;IN^ICU

 ;;NE^NEUROSURGERY OR

 ;;NO^UNKNOWN

 ;;OR^ORTHOPEDIC OR

 ;;OT^OTHER LOCATION

 ;;WA^WARD

 ;

FEED2 ;service location names

 ;;A^ANESTHESIA

 ;;I^IMPLANTS

 ;;C^SPINAL CORD

 ;;D^DENTAL

 ;;M^MEDICINE

 ;;P^PSYCH

 ;;S^SURGERY

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECXFELOC   8307     printed  Feb 18, 2025@23:19:03                                                                                                                                                                                                    Page 2

ECXFELOC  ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96  8:41 AM ] ;5/20/19  11:24

 +1       ;;3.0;DSS EXTRACTS;**1,8,105,132,136,149,174**;Dec 22, 1997;Build 33

EN        ;entry point from option

 +1        WRITE !!,"Print list of feeder locations.",!

           SET QFLG=1

 +2       ;149,174

           NEW ECXPORT,CNT,DIR,X,Y,DTOUT,DUOUT,ZTDESC,ZTRTN,ZTSAVE,ECY,SIEN,DIRUT

 +3       ;174

           SET DIR("?")="Select one or more feeder key systems to display"

 +4       ;174

           SET DIR("A")="Enter a list or range of numbers (1-9) or hit enter for all: "

           SET DIR("B")="1-9"

 +5       ;136,149,174

           WRITE !,"Select : 1. CLI",!,?9,"2. ECS",!,?9,"3. IVP",!,?9,"4. LAB",!,?9,"5. PRE",!,?9,"6. PRO",!,?9,"7. RAD",!,?9,"8. SUR",!,?9,"9. UDP",!

           SET DIR(0)="LA^1:9"

           DO ^DIR

           if $DATA(DIRUT)

               QUIT 

 +6       ;174

           KILL DIR

           SET ECY=Y

 +7       ;149

           SET ECXPORT=$$EXPORT^ECXUTL1

           if ECXPORT=-1

               QUIT 

 +8       ;Section added in 149

           IF $GET(ECXPORT)

               Begin DoDot:1

 +9                KILL ^TMP($JOB)

 +10      ;174

                   SET ^TMP($JOB,"ECXPORT",0)="FEEDER SYSTEM^FEEDER LOCATION^DIVISION^DESCRIPTION"

                   SET CNT=1

 +11               DO START

 +12               DO EXPDISP^ECXUTL1

               End DoDot:1

               QUIT 

 +13       KILL %ZIS

           SET %ZIS="Q"

           DO ^%ZIS

           if POP

               QUIT 

 +14      ;174

           IF $DATA(IO("Q"))

               SET ZTDESC="Feeder Location List (DSS)"

               SET ZTRTN="START^ECXFELOC"

               SET ZTSAVE("ECY")=""

               DO ^%ZTLOAD

               DO ^%ZISC

               GOTO OUT

START     ;queued entry point

 +1       ;174

           NEW ECLIST,EC

 +2        IF '$DATA(DT)

               SET DT=$$HTFM^XLFDT(+$HOROLOG)

 +3       ;149

           if '$GET(ECXPORT)

               KILL ^TMP($JOB)

           SET (QFLG,PG)=0

           SET $PIECE(LN,"-",81)=""

 +4       ;174

           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 IV

               if EC=4

                   DO LAB

               if EC=5

                   DO PRE

               if EC=6

                   DO PRO

               if EC=7

                   DO RAD

               if EC=8

                   DO SUR

               if EC=9

                   DO UDP

 +5       ;174

           USE IO

           DO PRINT

 +6       ;174

           QUIT 

LAB       ;174

           SET EC=0

           FOR 

               SET EC=$ORDER(^LRO(68,EC))

               if 'EC

                   QUIT 

               SET SIEN=0

               FOR 

                   SET SIEN=$ORDER(^LRO(68,EC,3,SIEN))

                   if '+SIEN

                       QUIT 

                   SET EC1=$GET(^LRO(68,EC,0))

                   SET ^TMP($JOB,"LAB",$PIECE(EC1,U,11),EC)=$$RADDIV^ECXDEPT($PIECE(^LRO(68,EC,3,SIEN,0),U))_U_$PIECE(EC1,U)

 +1       ;174

           QUIT 

ECS       ;174

           SET EC=0

           FOR 

               SET EC=$ORDER(^ECJ(EC))

               if 'EC

                   QUIT 

               IF $DATA(^(EC,0))

                   SET EC1=$PIECE(^(0),"-",1,2)

                   SET EC2=$PIECE($GET(^ECD(+$PIECE(EC1,"-",2),0)),U)

                   SET ^TMP($JOB,"ECS",EC1,EC1)=$$RADDIV^ECXDEPT($PIECE(EC1,"-"))_U_EC2

 +1        FOR 

               SET EC=$ORDER(^ECK(EC))

               if 'EC

                   QUIT 

               IF $DATA(^(EC,0))

                   SET EC1=$PIECE(^(0),"-",1,2)

                   SET EC2=$PIECE($GET(^ECD(+$PIECE(EC1,"-",2),0)),U)

                   SET ^TMP($JOB,"ECS",EC1,EC1)=EC2

 +2       ;174

           QUIT 

IV        ;174

           SET EC=0

           FOR 

               SET EC=$ORDER(^DG(40.8,EC))

               if 'EC

                   QUIT 

               IF $DATA(^DG(40.8,EC,0))

                   SET EC1=$EXTRACT($PIECE(^(0),U),1,30)

                   SET ^TMP($JOB,"IVP","IVP"_EC,EC)=$$GETDIV^ECXDEPT(EC)_U_"IV Pharmacy-"_EC1

 +1       ;174

           QUIT 

CLI        SET EC=0

           FOR 

               SET EC=$ORDER(^SC(EC))

               if 'EC

                   QUIT 

               IF $DATA(^(EC,0))

                   SET EC1=^(0)

                   SET ECS=$PIECE(EC1,U,15)

                   SET ECSC=$PIECE($GET(^DIC(40.7,+$PIECE(EC1,U,7),0)),U,2)

                   SET ECD=$PIECE(EC1,U)

                   if 'ECS

                       SET ECS=1

                   Begin DoDot:1

 +1       ;174

                       IF $PIECE(EC1,U,17)'="Y"

                           IF $PIECE(EC1,U,3)="C"

                               SET DAT=$GET(^SC(EC,"I"))

                               SET ID=+DAT

                               SET RD=$PIECE(DAT,U,2)

                               IF 'ID!(ID>DT)!(RD&(RD<DT))

                                   SET ^TMP($JOB,"CLI",ECS_ECSC,EC)=$$GETDIV^ECXDEPT(ECS)_U_ECD

                   End DoDot:1

 +2       ;174

           QUIT 

PRE        NEW ARRAY

           SET ARRAY="^TMP($J,""ECXDSS"")"

           KILL @ARRAY

           DO PSS^PSO59(,"??","ECXDSS")

           IF @ARRAY@(0)>0

               GOTO V6

 +1       ;dbia (#4689)

 +2        SET EC=0

           FOR 

               SET EC=$ORDER(^DIC(59,EC))

               if 'EC

                   QUIT 

               IF $DATA(^(EC,0))

                   SET EC1=$EXTRACT($PIECE(^(0),U),1,30)

                   SET ^TMP($JOB,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1

 +3       ;174

           QUIT 

V6        ;174

           SET EC=0

           FOR 

               SET EC=$ORDER(@ARRAY@(EC))

               if 'EC

                   QUIT 

               IF $DATA(^(EC))

                   SET EC1=$EXTRACT(@ARRAY@(EC,.01),1,30)

                   SET ^TMP($JOB,"PRE","PRE"_EC,EC)=$GET(@ARRAY@(EC,.06))_U_"Prescriptions-"_EC1

 +1        KILL @ARRAY

 +2       ;174

           QUIT 

RAD       ;174

           SET EC=0

           FOR 

               SET EC=$ORDER(^RA(79,EC))

               SET EC1=0

               if 'EC

                   QUIT 

               IF $DATA(^(EC,0))

                   SET ECD=$PIECE(^(0),U)

                   FOR 

                       SET EC1=$ORDER(^RA(79.2,EC1))

                       if 'EC1

                           QUIT 

                       IF $DATA(^(EC1,0))

                           SET ECD1=$PIECE(^(0),U)

                           SET ^TMP($JOB,"RAD",EC_"-"_EC1,EC_"-"_EC1)=$$RADDIV^ECXDEPT(ECD)_U_ECD_"-"_ECD1

 +1       ;174

           QUIT 

NUR       ;S EC=0 F  S EC=$O(^NURSF(211.4,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1 ;132

 +1       ;174

           QUIT 

SUR       ;174, Updated surgery section

 +1        NEW J,X,DIV,EC,EC31,ECF1,ECFL,ECFLX,ECFX,F1,F1SUB,F1NM,F2,F2SUB,F2NM,FL

 +2        KILL ^TMP($JOB,"ECXAUD")

 +3       ;setup array of feeder location names

 +4        FOR F1=1:1:14

               SET X=$PIECE($TEXT(FEED1+F1),";",3)

               SET F1SUB=$PIECE(X,U,1)

               SET F1NM=$PIECE(X,U,2)

               SET ^TMP($JOB,"ECXFL","OR"_F1SUB)=F1NM

               Begin DoDot:1

 +5                FOR F2=1:1:7

                       SET X=$PIECE($TEXT(FEED2+F2),";",3)

                       SET F2SUB=$PIECE(X,U,1)

                       SET F2NM=$PIECE(X,U,2)

                       SET ^TMP($JOB,"ECXFL","OR"_F1SUB_F2SUB)=F1NM_" - "_F2NM

                       SET FL(F2SUB)=F2NM

               End DoDot:1

 +6       ;process extract records

 +7       ;type='p'rimary or 's'econdary or 'i'mplant

 +8       ;ignore type=secondary

 +9        SET J=0

           FOR 

               SET J=$ORDER(^ECX(727.811,J))

               if 'J

                   QUIT 

               IF $DATA(^ECX(727.811,J,0))

                   SET EC=^(0)

                   SET DIV=$PIECE(EC,U,4)

                   IF $PIECE(EC,U,17)'="S"

                       IF $PIECE(EC,U,28)'="C"

                           Begin DoDot:1

 +10      ;determine feeder location

 +11                           SET ECF1=$EXTRACT($PIECE(EC,U,32),1,4)

 +12                           IF ECF1=""

                                   Begin DoDot:2

 +13                                   SET ECF1=$PIECE(EC,U,30)

                                       SET ECF1="OR"_$EXTRACT("GEORCANECNAMINENCYWACLDEOT",ECF1*2-1,ECF1*2)

 +14                                   if ECF1="OR"

                                           SET ECF1="ORNO"

 +15                                   IF $PIECE(EC,U,30)=""

                                           IF $PIECE(EC,U,12)=""

                                               IF $PIECE(EC,U,11)="059"

                                                   SET ECF1="ORCY"

                                   End DoDot:2

 +16                           SET ECFL=DIV_ECF1

 +17      ;type=implant generates one product record; volume is always at least 1

 +18                           IF $PIECE(EC,U,17)="I"

                                   Begin DoDot:2

 +19                                   SET ECFLX=ECFL_"I"

 +20                                   SET ^TMP($JOB,"SUR",ECFLX,ECFLX)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1_"I"))'="":^TMP($JOB,"ECXFL",ECF1_"I"),1:"NON-OR"_" - "_$GET(FL("I")))

                                   End DoDot:2

                                   QUIT 

 +21      ;type=primary generates four or five product records, but only two are of interest here

 +22      ;anesthesia time product

 +23                           SET ECQ=+$PIECE(EC,U,22)

                               IF ECQ>0

                                   Begin DoDot:2

 +24                                   SET ECFLX=ECFL_"A"

 +25                                   SET ^TMP($JOB,"SUR",ECFLX,ECFLX)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1_"A"))'="":^TMP($JOB,"ECXFL",ECF1_"A"),1:"NON-OR"_" - "_$GET(FL("A")))

                                   End DoDot:2

 +26      ;surgeon time product

 +27                           SET ECQ=+$PIECE(EC,U,21)

                               IF ECQ>0

                                   Begin DoDot:2

 +28                                   SET EC31=+$PIECE(EC,U,31)

                                       SET ECFX=$SELECT(EC31=10:"D",EC31=24:"M",EC31=32:"P",EC31=43:"C",1:"S")

 +29                                   SET ECFLX=ECFL_ECFX

 +30                                   SET ^TMP($JOB,"SUR",ECFLX,ECFLX)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1_ECFX))'="":^TMP($JOB,"ECXFL",ECF1_ECFX),1:"NON-OR"_" - "_$GET(FL(ECFX)))

                                   End DoDot:2

 +31      ;patient time product

 +32                           SET ECQ=+$PIECE(EC,U,20)

                               IF ECQ>0

                                   Begin DoDot:2

 +33                                   SET ^TMP($JOB,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1))'="":^TMP($JOB,"ECXFL",ECF1),1:"NON-OR")

                                   End DoDot:2

 +34      ;recovery room time product only if not cystoscopy and not non-or

 +35                           IF ECFL'="ORCY"

                                   IF $PIECE(EC,U,32)=""

                                       Begin DoDot:2

 +36                                       SET ECQ=+$PIECE(EC,U,33)

                                           IF ECQ>0

                                               Begin DoDot:3

 +37                                               SET ^TMP($JOB,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1))'="":^TMP($JOB,"ECXFL",ECF1),1:"NON-OR")

                                               End DoDot:3

                                       End DoDot:2

 +38      ;technician time product, only for cystoscopy

 +39                           IF ECFL="ORCY"

                                   Begin DoDot:2

 +40                                   SET ECQ=+$PIECE(EC,U,20)

                                       if ($PIECE(EC,U,22)>$PIECE(EC,U,20))

                                           SET ECQ=+$PIECE(EC,U,22)

                                       IF ECQ>0

                                           Begin DoDot:3

 +41                                           SET ^TMP($JOB,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1))'="":^TMP($JOB,"ECXFL",ECF1),1:"NON-OR")

                                           End DoDot:3

                                   End DoDot:2

 +42                           SET ^TMP($JOB,"SUR",ECFL,ECFL)=$$RADDIV^ECXDEPT(DIV)_U_$SELECT($GET(^TMP($JOB,"ECXFL",ECF1))'="":^TMP($JOB,"ECXFL",ECF1),1:"NON-OR")

                           End DoDot:1

 +43       KILL ^TMP($JOB,"ECXFL")

 +44       QUIT 

 +45      ;

UDP       ;174

           SET EC=0

           FOR 

               SET EC=$ORDER(^DG(40.8,EC))

               if 'EC

                   QUIT 

               IF $DATA(^DG(40.8,EC,0))

                   SET EC1=$EXTRACT($PIECE(^(0),U),1,30)

                   SET ^TMP($JOB,"UDP","UDP"_EC,EC)=$$GETDIV^ECXDEPT(EC)_U_"Unit Dose Medications-"_EC1

 +1       ;174

           QUIT 

DEN       ;S EC=0 F  S EC=$O(^DENT(225,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"DEN",EC1,EC)="Dental "_EC1

PRO       ;Prosthetics Location Information. API added in patch 136

 +1        NEW IEN,LOC,DIV,X,ORDER

 +2        SET IEN=0

           FOR 

               SET IEN=$ORDER(^ECX(727.826,IEN))

               if '+IEN

                   QUIT 

               SET LOC=$PIECE($GET(^ECX(727.826,IEN,0)),U,10)

               IF LOC'=""

                   if '$DATA(LOC(LOC))

                       SET LOC(LOC)=""

 +3        SET LOC=""

           FOR 

               SET LOC=$ORDER(LOC(LOC))

               if LOC=""

                   QUIT 

               Begin DoDot:1

 +4                SET DIV=$PIECE(LOC,$SELECT(LOC["NONL":"NONL",LOC["ORD":"ORD",LOC["HO2":"HO2",LOC["LAB":"LAB",1:""),1)

                   IF DIV=""

                       SET DIV=+LOC

 +5                SET DIC=4

                   SET DIC(0)="MXQ"

                   SET X=DIV

                   DO ^DIC

                   if Y=-1

                       QUIT 

 +6                SET ORDER=$PIECE(LOC,DIV,2)

 +7       ;174

                   SET ^TMP($JOB,"PRO",LOC,LOC)=$$RADDIV^ECXDEPT(DIV)_U_$PIECE(Y,U,2)_" "_$SELECT(ORDER="HO2":"Home Oxygen",ORDER="NONL":"Non Lab Location",ORDER="LAB":"Prosthetics Lab",ORDER="ORD":"Ordering Location",1:"")

               End DoDot:1

 +8       ;174

           QUIT 

 +9       ;

PRINT     ;

 +1       ;149

           SET EC=""

           FOR 

               SET EC=$ORDER(^TMP($JOB,EC))

               SET EC1=""

               if EC=""

                   QUIT 

               if QFLG

                   QUIT 

               if '$GET(ECXPORT)

                   DO HEAD

               if QFLG

                   QUIT 

               FOR 

                   SET EC1=$ORDER(^TMP($JOB,EC,EC1))

                   SET EC2=""

                   if EC1=""

                       QUIT 

                   if QFLG

                       QUIT 

                   FOR 

                       SET EC2=$ORDER(^TMP($JOB,EC,EC1,EC2))

                       if EC2=""

                           QUIT 

                       if QFLG

                           QUIT 

                       Begin DoDot:1

 +2       ;149

                           IF $GET(ECXPORT)

                               SET ^TMP($JOB,"ECXPORT",CNT)=EC_U_EC1_U_^(EC2)

                               SET CNT=CNT+1

                               QUIT 

 +3       ;174

                           WRITE !,EC1,?18,$PIECE(^(EC2),U),?28,$PIECE(^(EC2),U,2)

                           IF $Y+3>IOSL

                               DO HEAD

                               if QFLG

                                   QUIT 

                       End DoDot:1

OUT       ;149

           IF '$GET(ECXPORT)

               IF $EXTRACT(IOST)="C"&('QFLG)

                   SET DIR(0)="E"

                   Begin DoDot:1

 +1                    SET SS=22-$Y

                       FOR JJ=1:1:SS