VistA-FOIAVistA/r/EVENT_CAPTURE-EC--ECT--ECX/ECMUTL.m

282 lines
9.2 KiB
Mathematica

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