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 ---[H[J[2J[HECXFELOC 8307 printed Dec 13, 2024@01:52:39 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
WRITE !
End DoDot:1
DO ^DIR
KILL DIR
+2 ;149
if '$GET(ECXPORT)
KILL ^TMP($JOB)
KILL DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y
+3 ;149
IF '$GET(ECXPORT)
if $EXTRACT(IOST)'="C"
WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+4 ;149
QUIT
HEAD ;
+1 IF $EXTRACT(IOST)="C"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 IF $EXTRACT(IOST)="C"
IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+3 ;174
SET PG=PG+1
if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
WRITE !,?15,"Feeder Location List For Feeder System ",EC,?70,"Page: ",PG,!!,"FEEDER LOCATION",?18,"DIVISION",?28,"DESCRIPTION",!,LN
+4 QUIT
+5 ;
FEED1 ;or location names
+1 ;;AM^AMBULATORY OR
+2 ;;CA^CARDIAC OR
+3 ;;CL^CLINIC
+4 ;;CN^CARDIAC/NEURO OR
+5 ;;CY^CYSTOSCOPY RM.
+6 ;;DE^DEDICATED RM.
+7 ;;EN^ENDOSCOPY RM.
+8 ;;GE^GENERAL OR
+9 ;;IN^ICU
+10 ;;NE^NEUROSURGERY OR
+11 ;;NO^UNKNOWN
+12 ;;OR^ORTHOPEDIC OR
+13 ;;OT^OTHER LOCATION
+14 ;;WA^WARD
+15 ;
FEED2 ;service location names
+1 ;;A^ANESTHESIA
+2 ;;I^IMPLANTS
+3 ;;C^SPINAL CORD
+4 ;;D^DENTAL
+5 ;;M^MEDICINE
+6 ;;P^PSYCH
+7 ;;S^SURGERY
+8 ;
