ECMUTL ;ALB/ESD - Utilities for Multiple Dates/Mult Procs ;20 AUG 1997 13:56
;;2.0; EVENT CAPTURE ;**5,10,18,33,47,63**;8 May 96
;
ASKLOC() ; Get Location
; Input: None
;
; Output: ECL = Location (Division file pointer) ien
; ECLN = Location name
;
D ^ECL
K ECOUT,LOC
Q $S($D(ECL):1,1:0)
;
;
ASKPRDT(DSSU,ONE) ; Get Procedure Start Date/Time
; Input: ECD = DSS Unit ien
; ONE = Ask procedure start date/time once
;
; Output: ^TMP("ECPRDT",$J) = procedure date/time array
;
N DTOUT,DUOUT,ECCNT,ECDUP,ECERR
S (ECCNT,ECDUP,ECERR)=0
I '$G(DSSU) G ASKPRDTQ
I $P($G(^ECD(DSSU,0)),"^",12)="N" S DIR("B")="NOW"
AGAIN N DIRUT,Y
S DIR("A")="Select "_$S(+ECDUP:"Another Procedure Date and Time",1:"Procedure Date and Time")
S DIR("?")="Enter both date AND time procedure was performed. Future dates are not allowed."
S DIR(0)="DO^:NOW:EXR"
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) S ECERR=1
I +Y S ECDUP=1,^TMP("ECPRDT",$J,Y)="" G @($S('$G(ONE):"AGAIN",1:"ASKPRDTQ"))
;
ASKPRDTQ Q $S(ECERR:0,(+$G(ONE)&(+Y)):1,('$G(ONE))&($D(^TMP("ECPRDT",$J))):1,1:0)
;
;
ASKCAT(ECL,ECD) ; Get category
; Input: ECL = Location ien
; ECD = DSS Unit ien
;
; Output: ECATEG = Category ien (may be 0 if no categories)
;
N CATS,DIRUT,ECATEG,ECMAX,X
S ECATEG=0_"^No Categories",(ECMAX,X)=0
I '$G(ECL)!('$G(ECD)) G ASKCATQ
D CATS^ECHECK1
I $O(ECC(0))']"" G ASKCATQ
W !!,"Categories within "_$P($G(^ECD(+ECD,0)),"^")_":",!
F S X=$O(ECC(X)) Q:'X W !?5,X_". ",$P(ECC(X),"^",2) S ECMAX=X
W ! S DIR(0)="NA^1:"_ECMAX,DIR("A")="Select Number: "
D ^DIR K DIR
I 'Y!($D(DIRUT)) K ECATEG G ASKCATQ
I +Y S ECATEG=$G(ECC(Y))
ASKCATQ K CNT,ECAT,ECC
Q $G(ECATEG)
;
;
ASKPRO(ECL,ECD,ECC,NUM) ; Ask procedures
; Input: ECL = Location ien
; ECD = DSS Unit ien
; ECC = Category ien
; NUM = Only ask procedure once
;
; Output: ^TMP("ECPROC",$J) = procedure array
;
N CNT,ECERR,ECOUNT,ECOUT,ECPCNT,ECP,ECPNM,ECPREV,ECREAS,ECVOLU,ECEXIT
N ECX,ECMOD,ECMODS,ECCPT,ECDT
I '$D(ECL)!('$D(ECD)) G ASKPROQ
S ECC=+$G(ECC)
S ECOUNT=0
S ECDT=$O(^TMP("ECPRDT",$J,0))
D PROS^ECHECK1
I '$O(^TMP("ECPRO",$J,0)) D G ASKPROQ
. W !!,"Within the ",ECLN," location there are no procedures defined",!
. W "for the DSS Unit ",$P(ECDSSU,"^",2),".",!
. S DIR(0)="E" D ^DIR K DIR,Y
;
SEL ;
K ECPNAME,ECMOD
S (ECPNM,ECPREV,ECREAS,ECX)="",(CNT,ECPCNT,ECP,ECVOLU,ECEXIT)=0
S DIR("?")="^D LISTPR^ECMUTL"
W ! S ECX=$$GETPRO^ECDSUTIL
I +$G(ECX)=-1,('ECOUNT) D MSG^ECBEN2U,KILLV^ECDSUTIL G ASKPROQ
I +$G(ECX)=-1,ECOUNT G ASKPROQ
I +$G(ECX)=1 S ECPREV=$P(ECX,"^",2) D SRCHTM^ECDSUTIL(ECX)
S ECPCNT=+$G(ECPCNT)
I ECPCNT=-1!(ECPCNT=-2) D G SEL
. D @($S(ECPCNT=-1:"ERRMSG^ECDSUTIL",ECPCNT=-2:"ERRMSG2^ECDSUTIL"))
. D KILLV^ECDSUTIL
I ECPCNT>0 D D CONTINU G:$G(ECERR) ASKPROQ
. S CNT=ECPCNT
. I ECPREV="L" W $P($G(^TMP("ECPRO",$J,+$G(^TMP("ECLKUP",$J,"LAST")))),"^",4)
. I ECPREV="X"!(ECPREV="N") W " "_$P($G(^TMP("ECPRO",$J,+CNT)),"^",4)
I 'ECPCNT,$D(ECPNAME) D G:CNT=-1!($G(ECERR)) ASKPROQ
. S CNT=$$PRLST^ECDSUTIL
. I CNT=-1 D MSG^ECBEN2U,KILLV^ECDSUTIL Q
. I CNT>0 D
.. W " "_$S(ECPREV="S":$P($G(^TMP("ECPRO",$J,+CNT)),"^",3),1:$P($G(^TMP("ECPRO",$J,+CNT)),"^",4))
.. D CONTINU
;
I CNT>0,($G(ECP)'=""),(ECVOLU>0) D
. S ECOUNT=$S(+$G(NUM)=-99:1,+$G(NUM)>0:NUM,1:(ECOUNT+1))
. S ^TMP("ECPROC",$J,(ECOUNT))=ECP_"^"_ECPNM_"^"_+ECREAS_"^"_$S(+ECREAS:$P($G(^ECR($P($G(^ECL(+ECREAS,0)),"^"),0)),"^"),1:"Reason Not Defined")_"^"_ECVOLU
. S ECCPT=$S(ECP["EC":$P($G(^EC(725,+ECP,0)),"^",5),1:+ECP)
. I ECCPT'="",$O(ECMOD(ECCPT,""))'="" D
. . M ^TMP("ECPROC",$J,ECOUNT,"MOD")=ECMOD(ECCPT)
I '$G(NUM) G SEL
ASKPROQ K ^TMP("ECPRO",$J),^TMP("ECLKUP",$J),JJ,OK
D KILLV^ECDSUTIL
Q
;
CONTINU ;
D SETP
S ECCPT=$S(ECP["EC":$P($G(^EC(725,+ECP,0)),"^",5),1:+ECP)
I ECCPT'="" D I $G(ECERR) G CONTINUQ
. S ECMODS=$G(ECMODS)
. S ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.ECERR)
. K ECMODF,ECMODS
S ECREAS=$$ASKREAS(ECL,ECD,ECC,ECP,.ECERR)
G:$G(ECERR) CONTINUQ
S ECVOLU=$$ASKVOL(ECL,ECD,ECC,ECP,.ECERR)
CONTINUQ Q
;
SETP ;
S ^TMP("ECLKUP",$J,"LAST")=CNT
S ECP=$P($G(^TMP("ECPRO",$J,CNT)),"^"),ECPNM=$P($G(^TMP("ECPRO",$J,CNT)),"^",4)
Q
;
LISTPR ;- List available procedures
; Input: None
;
; Output: None (display on screen)
;
N DIR,DIRUT,ECI,Y
S ECI=0
D PROCHDR
F S ECI=$O(^TMP("ECPRO",$J,ECI)) Q:'ECI!(ECEXIT) D
. I ($Y+5>IOSL) S DIR(0)="E" D ^DIR S:'Y!$D(DIRUT) ECEXIT=1 I +Y D PROCHDR
. Q:ECEXIT
. W !,ECI_".",?5,$E($P(^TMP("ECPRO",$J,ECI),"^",4),1,30),?38,$E($P(^(ECI),"^",3),1,30),?72,$P(^(ECI),"^",5)
Q:ECEXIT
W !!?5,"Select by number, CPT or national code, procedure name, or synonym.",!?5,"Synonym must be preceded by the & character (example: &TESTSYN).",!
W ?2,"** Modifier(s) can be appended to a CPT code (ex: CPT code-mod1,mod2,mod3) **",!
LISTPRQ Q
;
PROCHDR ;- Procedure display header
;
W @IOF
W !,"Available Procedures within "_$P(ECDSSU,"^",2)_": ",!
W ?72,"National",!,?5,"Procedure Name",?40,"Synonym",?72,"Number",!
Q
;
;
ASKREAS(ECL,ECD,ECC,ECP,ECOUT) ;-Ask procedure reason
; Input: ECL = Location ien
; ECD = DSS Unit ien
; ECC = Category ien
; ECP = Procedure ien
;
; Output: ECPRPTR = Link file ien (from file #720.5)
; ECOUT = 0 if successful
; 1 if uparrowed or timed out
; (passed by reference)
;
N DTOUT,DUOUT,ECPRPTR,ECSCR
S (ECOUT,ECPRPTR,ECSCR)=0
S ECC=+$G(ECC)
I '$D(ECL)!('$D(ECD))!('$D(ECP)) G ASKREASQ
I $G(ECP)]"" S ECSCR=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
I ECSCR>0,(+$P($G(^ECJ(ECSCR,"PRO")),"^",5)),(+$O(^ECL("AD",ECSCR,0))) D
. S DIC="^ECL(",DIC(0)="QEAM"
. S DIC("A")="Procedure Reason: ",DIC("S")="I $P(^(0),U,2)=ECSCR"
. D ^DIC K DIC
. I +Y>0 S ECPRPTR=+Y
. I $D(DTOUT)!($D(DUOUT)) S ECOUT=1
ASKREASQ Q +ECPRPTR
;
;
ASKVOL(ECL,ECD,ECC,ECP,ECOUT) ;- Ask procedure volume
; Input: ECL = Location ien
; ECD = DSS Unit ien
; ECC = Category ien
; ECP = Procedure ien
;
; Output: ECVOL = volume
; ECOUT = 0 if successful
; 1 if uparrowed or timed out
; (passed by reference)
;
N DIR,DIRUT,DTOUT,DUOUT,ECSCR,ECVOL
S (ECOUT,ECSCR,ECVOL)=0
S ECC=+$G(ECC)
I '$D(ECL)!('$D(ECD))!('$D(ECP)) G ASKVOLQ
I $G(ECP)]"" S ECSCR=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
S DIR(0)="N^^K:(X<1)!(X>99) X",DIR("A")="Volume"
S DIR("?")="Type a Number between 1 and 99, 0 Decimal Digits"
S DIR("B")=$S($P($G(^ECJ(ECSCR,"PRO")),"^",3):$P($G(^ECJ(ECSCR,"PRO")),"^",3),1:1)
D ^DIR
I +Y S ECVOL=Y
I $D(DIRUT) S ECOUT=1
ASKVOLQ Q +ECVOL
;
;
PROV(ECDT,ECPROVS) ;get providers - new providers function
;- This is the same function as PROV^ECPRVUTL
;- Select provider(s) with active person class
;- No updating of file #721 record is done here
;
; input
; ECDT = date/time of procedure (required)
; ECPROVS = local array, passed by reference (required)
;
; output
; ECU(1) = provider #1 (mandatory) ien^provider #1 name^person class
; ECU(2) = provider #2 (optional) ien^provider #2 name^person class
; ECU(3) = provider #3 (optional) ien^provider #3 name^person class
;
; returns
; 0 ==> prov selection successful; at least prov #1 selected
; 1 ==> selection unsuccessful or user timed-out
; 2 ==> selection unsuccessful or user entered "^"
;
N ECU,ECU2,ECU3,ECDA
D GET^ECPRVUTL("",ECDT,.ECU,.ECU2,.ECU3,.ECOUT)
S ECPROVS(1)=ECU,ECPROVS(2)=ECU2,ECPROVS(3)=ECU3
Q ECOUT
;
ONEUNIT(ECDSSU) ;- Create ECDSSU containing DSS Unit
; Checks for validity and access to Unit
;
; input
; ECDSSU = passed by reference
;
; output
; ECDDSU = ien in file #724^name of DSS unit OR
; undefined
;
; returns ECOUT = 0 if unit selection sucessful OR
; 1 if user times out; selection unsuccessful
; 2 if user up-arrows out; selection unsuccessful
; Note: if selection is unsuccessful, variable ECDSSU will be undefined.
;
N Y,DIRUT,DUOUT,ECKEY,ECOUT
S ECKEY=$S($D(^XUSEC("ECALLU",DUZ)):1,1:0)
F S ECOUT=0 D Q:$G(ECOUT) Q:$G(ECDSSU)
.K DUOUT,DTOUT,DIRUT,Y
.W !
.S DIC=724,DIC("A")="Select DSS Unit: ",DIC(0)="QEAMZ"
.S DIC("S")="I ECKEY!($D(^VA(200,DUZ,""EC"",+Y)))"
.D ^DIC K DIC
.S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
.Q:$G(ECOUT)
.I +Y>0 D Q
.. I $$VALID(+Y) S ECDSSU=Y
.. I '$$VALID(+Y) D
...S Y=-1
...W !!,?5,"This DSS Unit is either inactive or cannot be used"
...W !,?5,"in Event Capture. Please select a different DSS Unit.",!
.I +Y<0 D Q
..W !!,?5,"A response is required...try again."
..W !,?5,"You must enter an ""^"" to exit."
.K DIR,DUOUT,DTOUT,DIRUT
.W ! S DIR(0)="YA",DIR("A")="Is this correct? ",DIR("B")="YES"
.S DIR("?")="Answer YES to accept the unit, NO to start over."
.D ^DIR K DIR
.I $D(DIRUT) S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2 K ECDSSU Q
.I '$G(Y) K ECDSSU
Q ECOUT
;
VALID(IEN) ;- Check DSS Unit for use by Event Capture
;
N NODE,NO,YES,VAL
S NODE=$G(^ECD(IEN,0))
;piece 6 is 'inactive'; piece 8 is 'use with EC'
S NO=$P(NODE,"^",6),YES=$P(NODE,"^",8)
;start out with 'valid'
S VAL=1 D
.;if 'inactive', then 'not valid'
.I NO S VAL=0 Q
.;if not 'use with EC', then 'not valid'
.I 'YES S VAL=0
Q VAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECMUTL 9713 printed Dec 13, 2024@01:57:46 Page 2
ECMUTL ;ALB/ESD - Utilities for Multiple Dates/Mult Procs ;20 AUG 1997 13:56
+1 ;;2.0; EVENT CAPTURE ;**5,10,18,33,47,63**;8 May 96
+2 ;
ASKLOC() ; Get Location
+1 ; Input: None
+2 ;
+3 ; Output: ECL = Location (Division file pointer) ien
+4 ; ECLN = Location name
+5 ;
+6 DO ^ECL
+7 KILL ECOUT,LOC
+8 QUIT $SELECT($DATA(ECL):1,1:0)
+9 ;
+10 ;
ASKPRDT(DSSU,ONE) ; Get Procedure Start Date/Time
+1 ; Input: ECD = DSS Unit ien
+2 ; ONE = Ask procedure start date/time once
+3 ;
+4 ; Output: ^TMP("ECPRDT",$J) = procedure date/time array
+5 ;
+6 NEW DTOUT,DUOUT,ECCNT,ECDUP,ECERR
+7 SET (ECCNT,ECDUP,ECERR)=0
+8 IF '$GET(DSSU)
GOTO ASKPRDTQ
+9 IF $PIECE($GET(^ECD(DSSU,0)),"^",12)="N"
SET DIR("B")="NOW"
AGAIN NEW DIRUT,Y
+1 SET DIR("A")="Select "_$SELECT(+ECDUP:"Another Procedure Date and Time",1:"Procedure Date and Time")
+2 SET DIR("?")="Enter both date AND time procedure was performed. Future dates are not allowed."
+3 SET DIR(0)="DO^:NOW:EXR"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
SET ECERR=1
+6 IF +Y
SET ECDUP=1
SET ^TMP("ECPRDT",$JOB,Y)=""
GOTO @($SELECT('$GET(ONE):"AGAIN",1:"ASKPRDTQ"))
+7 ;
ASKPRDTQ QUIT $SELECT(ECERR:0,(+$GET(ONE)&(+Y)):1,('$GET(ONE))&($DATA(^TMP("ECPRDT",$JOB))):1,1:0)
+1 ;
+2 ;
ASKCAT(ECL,ECD) ; Get category
+1 ; Input: ECL = Location ien
+2 ; ECD = DSS Unit ien
+3 ;
+4 ; Output: ECATEG = Category ien (may be 0 if no categories)
+5 ;
+6 NEW CATS,DIRUT,ECATEG,ECMAX,X
+7 SET ECATEG=0_"^No Categories"
SET (ECMAX,X)=0
+8 IF '$GET(ECL)!('$GET(ECD))
GOTO ASKCATQ
+9 DO CATS^ECHECK1
+10 IF $ORDER(ECC(0))']""
GOTO ASKCATQ
+11 WRITE !!,"Categories within "_$PIECE($GET(^ECD(+ECD,0)),"^")_":",!
+12 FOR
SET X=$ORDER(ECC(X))
if 'X
QUIT
WRITE !?5,X_". ",$PIECE(ECC(X),"^",2)
SET ECMAX=X
+13 WRITE !
SET DIR(0)="NA^1:"_ECMAX
SET DIR("A")="Select Number: "
+14 DO ^DIR
KILL DIR
+15 IF 'Y!($DATA(DIRUT))
KILL ECATEG
GOTO ASKCATQ
+16 IF +Y
SET ECATEG=$GET(ECC(Y))
ASKCATQ KILL CNT,ECAT,ECC
+1 QUIT $GET(ECATEG)
+2 ;
+3 ;
ASKPRO(ECL,ECD,ECC,NUM) ; Ask procedures
+1 ; Input: ECL = Location ien
+2 ; ECD = DSS Unit ien
+3 ; ECC = Category ien
+4 ; NUM = Only ask procedure once
+5 ;
+6 ; Output: ^TMP("ECPROC",$J) = procedure array
+7 ;
+8 NEW CNT,ECERR,ECOUNT,ECOUT,ECPCNT,ECP,ECPNM,ECPREV,ECREAS,ECVOLU,ECEXIT
+9 NEW ECX,ECMOD,ECMODS,ECCPT,ECDT
+10 IF '$DATA(ECL)!('$DATA(ECD))
GOTO ASKPROQ
+11 SET ECC=+$GET(ECC)
+12 SET ECOUNT=0
+13 SET ECDT=$ORDER(^TMP("ECPRDT",$JOB,0))
+14 DO PROS^ECHECK1
+15 IF '$ORDER(^TMP("ECPRO",$JOB,0))
Begin DoDot:1
+16 WRITE !!,"Within the ",ECLN," location there are no procedures defined",!
+17 WRITE "for the DSS Unit ",$PIECE(ECDSSU,"^",2),".",!
+18 SET DIR(0)="E"
DO ^DIR
KILL DIR,Y
End DoDot:1
GOTO ASKPROQ
+19 ;
SEL ;
+1 KILL ECPNAME,ECMOD
+2 SET (ECPNM,ECPREV,ECREAS,ECX)=""
SET (CNT,ECPCNT,ECP,ECVOLU,ECEXIT)=0
+3 SET DIR("?")="^D LISTPR^ECMUTL"
+4 WRITE !
SET ECX=$$GETPRO^ECDSUTIL
+5 IF +$GET(ECX)=-1
IF ('ECOUNT)
DO MSG^ECBEN2U
DO KILLV^ECDSUTIL
GOTO ASKPROQ
+6 IF +$GET(ECX)=-1
IF ECOUNT
GOTO ASKPROQ
+7 IF +$GET(ECX)=1
SET ECPREV=$PIECE(ECX,"^",2)
DO SRCHTM^ECDSUTIL(ECX)
+8 SET ECPCNT=+$GET(ECPCNT)
+9 IF ECPCNT=-1!(ECPCNT=-2)
Begin DoDot:1
+10 DO @($SELECT(ECPCNT=-1:"ERRMSG^ECDSUTIL",ECPCNT=-2:"ERRMSG2^ECDSUTIL"))
+11 DO KILLV^ECDSUTIL
End DoDot:1
GOTO SEL
+12 IF ECPCNT>0
Begin DoDot:1
+13 SET CNT=ECPCNT
+14 IF ECPREV="L"
WRITE $PIECE($GET(^TMP("ECPRO",$JOB,+$GET(^TMP("ECLKUP",$JOB,"LAST")))),"^",4)
+15 IF ECPREV="X"!(ECPREV="N")
WRITE " "_$PIECE($GET(^TMP("ECPRO",$JOB,+CNT)),"^",4)
End DoDot:1
DO CONTINU
if $GET(ECERR)
GOTO ASKPROQ
+16 IF 'ECPCNT
IF $DATA(ECPNAME)
Begin DoDot:1
+17 SET CNT=$$PRLST^ECDSUTIL
+18 IF CNT=-1
DO MSG^ECBEN2U
DO KILLV^ECDSUTIL
QUIT
+19 IF CNT>0
Begin DoDot:2
+20 WRITE " "_$SELECT(ECPREV="S":$PIECE($GET(^TMP("ECPRO",$JOB,+CNT)),"^",3),1:$PIECE($GET(^TMP("ECPRO",$JOB,+CNT)),"^",4))
+21 DO CONTINU
End DoDot:2
End DoDot:1
if CNT=-1!($GET(ECERR))
GOTO ASKPROQ
+22 ;
+23 IF CNT>0
IF ($GET(ECP)'="")
IF (ECVOLU>0)
Begin DoDot:1
+24 SET ECOUNT=$SELECT(+$GET(NUM)=-99:1,+$GET(NUM)>0:NUM,1:(ECOUNT+1))
+25 SET ^TMP("ECPROC",$JOB,(ECOUNT))=ECP_"^"_ECPNM_"^"_+ECREAS_"^"_$SELECT(+ECREAS:$PIECE($GET(^ECR($PIECE($GET(^ECL(+ECREAS,0)),"^"),0)),"^"),1:"Reason Not Defined")_"^"_ECVOLU
+26 SET ECCPT=$SELECT(ECP["EC":$PIECE($GET(^EC(725,+ECP,0)),"^",5),1:+ECP)
+27 IF ECCPT'=""
IF $ORDER(ECMOD(ECCPT,""))'=""
Begin DoDot:2
+28 MERGE ^TMP("ECPROC",$JOB,ECOUNT,"MOD")=ECMOD(ECCPT)
End DoDot:2
End DoDot:1
+29 IF '$GET(NUM)
GOTO SEL
ASKPROQ KILL ^TMP("ECPRO",$JOB),^TMP("ECLKUP",$JOB),JJ,OK
+1 DO KILLV^ECDSUTIL
+2 QUIT
+3 ;
CONTINU ;
+1 DO SETP
+2 SET ECCPT=$SELECT(ECP["EC":$PIECE($GET(^EC(725,+ECP,0)),"^",5),1:+ECP)
+3 IF ECCPT'=""
Begin DoDot:1
+4 SET ECMODS=$GET(ECMODS)
+5 SET ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.ECERR)
+6 KILL ECMODF,ECMODS
End DoDot:1
IF $GET(ECERR)
GOTO CONTINUQ
+7 SET ECREAS=$$ASKREAS(ECL,ECD,ECC,ECP,.ECERR)
+8 if $GET(ECERR)
GOTO CONTINUQ
+9 SET ECVOLU=$$ASKVOL(ECL,ECD,ECC,ECP,.ECERR)
CONTINUQ QUIT
+1 ;
SETP ;
+1 SET ^TMP("ECLKUP",$JOB,"LAST")=CNT
+2 SET ECP=$PIECE($GET(^TMP("ECPRO",$JOB,CNT)),"^")
SET ECPNM=$PIECE($GET(^TMP("ECPRO",$JOB,CNT)),"^",4)
+3 QUIT
+4 ;
LISTPR ;- List available procedures
+1 ; Input: None
+2 ;
+3 ; Output: None (display on screen)
+4 ;
+5 NEW DIR,DIRUT,ECI,Y
+6 SET ECI=0
+7 DO PROCHDR
+8 FOR
SET ECI=$ORDER(^TMP("ECPRO",$JOB,ECI))
if 'ECI!(ECEXIT)
QUIT
Begin DoDot:1
+9 IF ($Y+5>IOSL)
SET DIR(0)="E"
DO ^DIR
if 'Y!$DATA(DIRUT)
SET ECEXIT=1
IF +Y
DO PROCHDR
+10 if ECEXIT
QUIT
+11 WRITE !,ECI_".",?5,$EXTRACT($PIECE(^TMP("ECPRO",$JOB,ECI),"^",4),1,30),?38,$EXTRACT($PIECE(^(ECI),"^",3),1,30),?72,$PIECE(^(ECI),"^",5)
End DoDot:1
+12 if ECEXIT
QUIT
+13 WRITE !!?5,"Select by number, CPT or national code, procedure name, or synonym.",!?5,"Synonym must be preceded by the & character (example: &TESTSYN).",!
+14 WRITE ?2,"** Modifier(s) can be appended to a CPT code (ex: CPT code-mod1,mod2,mod3) **",!
LISTPRQ QUIT
+1 ;
PROCHDR ;- Procedure display header
+1 ;
+2 WRITE @IOF
+3 WRITE !,"Available Procedures within "_$PIECE(ECDSSU,"^",2)_": ",!
+4 WRITE ?72,"National",!,?5,"Procedure Name",?40,"Synonym",?72,"Number",!
+5 QUIT
+6 ;
+7 ;
ASKREAS(ECL,ECD,ECC,ECP,ECOUT) ;-Ask procedure reason
+1 ; Input: ECL = Location ien
+2 ; ECD = DSS Unit ien
+3 ; ECC = Category ien
+4 ; ECP = Procedure ien
+5 ;
+6 ; Output: ECPRPTR = Link file ien (from file #720.5)
+7 ; ECOUT = 0 if successful
+8 ; 1 if uparrowed or timed out
+9 ; (passed by reference)
+10 ;
+11 NEW DTOUT,DUOUT,ECPRPTR,ECSCR
+12 SET (ECOUT,ECPRPTR,ECSCR)=0
+13 SET ECC=+$GET(ECC)
+14 IF '$DATA(ECL)!('$DATA(ECD))!('$DATA(ECP))
GOTO ASKREASQ
+15 IF $GET(ECP)]""
SET ECSCR=+$ORDER(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
+16 IF ECSCR>0
IF (+$PIECE($GET(^ECJ(ECSCR,"PRO")),"^",5))
IF (+$ORDER(^ECL("AD",ECSCR,0)))
Begin DoDot:1
+17 SET DIC="^ECL("
SET DIC(0)="QEAM"
+18 SET DIC("A")="Procedure Reason: "
SET DIC("S")="I $P(^(0),U,2)=ECSCR"
+19 DO ^DIC
KILL DIC
+20 IF +Y>0
SET ECPRPTR=+Y
+21 IF $DATA(DTOUT)!($DATA(DUOUT))
SET ECOUT=1
End DoDot:1
ASKREASQ QUIT +ECPRPTR
+1 ;
+2 ;
ASKVOL(ECL,ECD,ECC,ECP,ECOUT) ;- Ask procedure volume
+1 ; Input: ECL = Location ien
+2 ; ECD = DSS Unit ien
+3 ; ECC = Category ien
+4 ; ECP = Procedure ien
+5 ;
+6 ; Output: ECVOL = volume
+7 ; ECOUT = 0 if successful
+8 ; 1 if uparrowed or timed out
+9 ; (passed by reference)
+10 ;
+11 NEW DIR,DIRUT,DTOUT,DUOUT,ECSCR,ECVOL
+12 SET (ECOUT,ECSCR,ECVOL)=0
+13 SET ECC=+$GET(ECC)
+14 IF '$DATA(ECL)!('$DATA(ECD))!('$DATA(ECP))
GOTO ASKVOLQ
+15 IF $GET(ECP)]""
SET ECSCR=+$ORDER(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
+16 SET DIR(0)="N^^K:(X<1)!(X>99) X"
SET DIR("A")="Volume"
+17 SET DIR("?")="Type a Number between 1 and 99, 0 Decimal Digits"
+18 SET DIR("B")=$SELECT($PIECE($GET(^ECJ(ECSCR,"PRO")),"^",3):$PIECE($GET(^ECJ(ECSCR,"PRO")),"^",3),1:1)
+19 DO ^DIR
+20 IF +Y
SET ECVOL=Y
+21 IF $DATA(DIRUT)
SET ECOUT=1
ASKVOLQ QUIT +ECVOL
+1 ;
+2 ;
PROV(ECDT,ECPROVS) ;get providers - new providers function
+1 ;- This is the same function as PROV^ECPRVUTL
+2 ;- Select provider(s) with active person class
+3 ;- No updating of file #721 record is done here
+4 ;
+5 ; input
+6 ; ECDT = date/time of procedure (required)
+7 ; ECPROVS = local array, passed by reference (required)
+8 ;
+9 ; output
+10 ; ECU(1) = provider #1 (mandatory) ien^provider #1 name^person class
+11 ; ECU(2) = provider #2 (optional) ien^provider #2 name^person class
+12 ; ECU(3) = provider #3 (optional) ien^provider #3 name^person class
+13 ;
+14 ; returns
+15 ; 0 ==> prov selection successful; at least prov #1 selected
+16 ; 1 ==> selection unsuccessful or user timed-out
+17 ; 2 ==> selection unsuccessful or user entered "^"
+18 ;
+19 NEW ECU,ECU2,ECU3,ECDA
+20 DO GET^ECPRVUTL("",ECDT,.ECU,.ECU2,.ECU3,.ECOUT)
+21 SET ECPROVS(1)=ECU
SET ECPROVS(2)=ECU2
SET ECPROVS(3)=ECU3
+22 QUIT ECOUT
+23 ;
ONEUNIT(ECDSSU) ;- Create ECDSSU containing DSS Unit
+1 ; Checks for validity and access to Unit
+2 ;
+3 ; input
+4 ; ECDSSU = passed by reference
+5 ;
+6 ; output
+7 ; ECDDSU = ien in file #724^name of DSS unit OR
+8 ; undefined
+9 ;
+10 ; returns ECOUT = 0 if unit selection sucessful OR
+11 ; 1 if user times out; selection unsuccessful
+12 ; 2 if user up-arrows out; selection unsuccessful
+13 ; Note: if selection is unsuccessful, variable ECDSSU will be undefined.
+14 ;
+15 NEW Y,DIRUT,DUOUT,ECKEY,ECOUT
+16 SET ECKEY=$SELECT($DATA(^XUSEC("ECALLU",DUZ)):1,1:0)
+17 FOR
SET ECOUT=0
Begin DoDot:1
+18 KILL DUOUT,DTOUT,DIRUT,Y
+19 WRITE !
+20 SET DIC=724
SET DIC("A")="Select DSS Unit: "
SET DIC(0)="QEAMZ"
+21 SET DIC("S")="I ECKEY!($D(^VA(200,DUZ,""EC"",+Y)))"
+22 DO ^DIC
KILL DIC
+23 if $DATA(DTOUT)
SET ECOUT=1
if $DATA(DUOUT)
SET ECOUT=2
+24 if $GET(ECOUT)
QUIT
+25 IF +Y>0
Begin DoDot:2
+26 IF $$VALID(+Y)
SET ECDSSU=Y
+27 IF '$$VALID(+Y)
Begin DoDot:3
+28 SET Y=-1
+29 WRITE !!,?5,"This DSS Unit is either inactive or cannot be used"
+30 WRITE !,?5,"in Event Capture. Please select a different DSS Unit.",!
End DoDot:3
End DoDot:2
QUIT
+31 IF +Y<0
Begin DoDot:2
+32 WRITE !!,?5,"A response is required...try again."
+33 WRITE !,?5,"You must enter an ""^"" to exit."
End DoDot:2
QUIT
+34 KILL DIR,DUOUT,DTOUT,DIRUT
+35 WRITE !
SET DIR(0)="YA"
SET DIR("A")="Is this correct? "
SET DIR("B")="YES"
+36 SET DIR("?")="Answer YES to accept the unit, NO to start over."
+37 DO ^DIR
KILL DIR
+38 IF $DATA(DIRUT)
if $DATA(DTOUT)
SET ECOUT=1
if $DATA(DUOUT)
SET ECOUT=2
KILL ECDSSU
QUIT
+39 IF '$GET(Y)
KILL ECDSSU
End DoDot:1
if $GET(ECOUT)
QUIT
if $GET(ECDSSU)
QUIT
+40 QUIT ECOUT
+41 ;
VALID(IEN) ;- Check DSS Unit for use by Event Capture
+1 ;
+2 NEW NODE,NO,YES,VAL
+3 SET NODE=$GET(^ECD(IEN,0))
+4 ;piece 6 is 'inactive'; piece 8 is 'use with EC'
+5 SET NO=$PIECE(NODE,"^",6)
SET YES=$PIECE(NODE,"^",8)
+6 ;start out with 'valid'
+7 SET VAL=1
Begin DoDot:1
+8 ;if 'inactive', then 'not valid'
+9 IF NO
SET VAL=0
QUIT
+10 ;if not 'use with EC', then 'not valid'
+11 IF 'YES
SET VAL=0
End DoDot:1
+12 QUIT VAL
