ECBEN2A ;BIR/MAM,JPW-Categories and Procedures Selection ;30 Apr 96
;;2.0; EVENT CAPTURE ;**1,4,5,13,18,33,47,72**;8 May 96
CHK ; check unit for valid categories
S (COUNT,EC1)=0 K ECHOICE,ECSTOP
D CATS^ECHECK1 S ECONE=""
I '$D(ECC(1)) S ECC=0,ECCN="None",ECONE=0 G P
I '$D(ECC(2)) S ECC=+ECC(1),ECCN=$P(ECC(1),"^",2),ECONE=1 G P
CATS ; select category
S X="",CNT=0
LIST D HDR^ECBEN2U S JJ=0 W !,"Categories within "_ECDN_": ",!
S EC1=0
F S CNT=$O(ECC(CNT)) Q:'CNT!$D(ECHOICE) D:($Y+5>IOSL) SELC Q:$D(ECHOICE) I X="" W !,CNT_".",?5,$P(ECC(CNT),"^",2)
I '$D(ECSTOP),$D(ECHOICE) S ECONE=2 G P
PICK W !!,"Select Number: " R X:DTIME I '$T!("^"[X) S ECOUT=1 Q
I '$D(ECC(X)) W !!,"Select the number corresponding to the category, or ^ to quit.",!!,"Press <RET> to continue " R X:DTIME S CNT=CNT-5,X="" G LIST
S ECHOICE=1,ECC=$P(ECC(X),"^"),ECCN=$P(ECC(X),"^",2),ECONE=2
P ;check for valid procedures
K ^TMP("ECLKUP",$J)
D PROS^ECHECK1
I '$O(^TMP("ECPRO",$J,0)) D Q:ECOUT
.W !!,"Within the ",ECLN," location there are no procedures defined",!
.W "for the DSS Unit ",ECDN,". Please select another DSS Unit.",!!
.W "Press <RET> to continue " R X:DTIME S ECOUT=2 Q
D HDR^ECBEN2U
P1 ;
I '$D(^TMP("ECPRO",$J,2)) S CNT=1,ECONE=ECONE_"^1" D SETP W !,"Procedure: " D G V
. W $S(ECCPT="":"",1:ECPTCD_" ")_$E(ECPN,1,50)
. W $S(SYN'["NOT DEFINED":" ["_SYN_"]",1:"")_" (#"_NATN_")",!
P2 ;ask mul proc
S ECX="",(ECPCNT,CNT,OK)=0,EC1=1 K ECHOICE,ECSTOP,ECMOD
S DIR("?")="^D PROS^ECBEN2A"
S ECX=$$GETPRO^ECDSUTIL
I +$G(ECX)=-1,(COUNT=0) D MSG^ECBEN2U,KILLV^ECDSUTIL Q
I +$G(ECX)=-1,COUNT G FILE
I +$G(ECX)=1 D SRCHTM^ECDSUTIL(ECX)
S ECPCNT=+$G(ECPCNT)
I ECPCNT=-1!(ECPCNT=-2) D G P2
. D @($S(ECPCNT=-1:"ERRMSG^ECDSUTIL",ECPCNT=-2:"ERRMSG2^ECDSUTIL"))
. D KILLV^ECDSUTIL
I ECPCNT>0 D G V
. S CNT=ECPCNT
. D SETP
. S OK=1,ECONE=ECONE_"^2"
. D KILLV^ECDSUTIL
I 'ECPCNT,$D(ECPNAME) S CNT=$$PRLST^ECDSUTIL
I CNT=-1 D MSG^ECBEN2U,KILLV^ECDSUTIL Q
I CNT>0 D G V
. D SETP
. S OK=1,ECONE=ECONE_"^2"
. D KILLV^ECDSUTIL
Q
;
PROS ;
S X="",CNT=0 K ECHOICE
LISTP D HDR^ECBEN2U S JJ=1 W !,"Available Procedures within "_ECDN_": ",!
W ?72,"National",!,?5,"Procedure Name",?40,"Synonym",?72,"Number",!
S EC1=1
F S CNT=$O(^TMP("ECPRO",$J,CNT)) Q:'CNT!$D(ECHOICE) D:($Y+5>IOSL) SELC Q:$D(ECHOICE) I X="" W !,CNT_".",?5,$E($P(^TMP("ECPRO",$J,CNT),"^",4),1,30),?38,$E($P(^(CNT),"^",3),1,30),?72,$P(^(CNT),"^",5)
I X="" D
.W !!?5,"Select by number, CPT or national code, procedure name, or synonym."
.W !?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) **",!
Q
;
V ;vol (and procedure reason),ask for CPT modifier is applicable
;
;ALB/JAM - Ask CPT Procedure Modifier
I ECCPT'="" D I ECOUT Q
. S ECMODS=$G(ECMODS)
. S ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.ECERR)
. I $G(ECERR) S ECOUT=1
. K ECMODF,ECMODS
;ALB/ESD - Ask Procedure Reason
I $G(ECP)]"" S ECSCR=+$O(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
K ECPRPTR
I ECSCR>0,($P($G(^ECJ(ECSCR,"PRO")),"^",5)=1),(+$O(^ECL("AD",ECSCR,0))) D
. S ECPRPTR=0
. 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
K ECSCR
;
VV ;vol
S:'VOL VOL=1
W !,"Volume: "_VOL_"// " R X:DTIME I '$T S ECOUT=1 Q
I X="^" S ECOUT=1 Q
S:X="" X=VOL I X'?1.2N!'X W !!,"Enter a whole number between 1 and 99." G VV
S ECV=X
CHKP ;
W !!,"Category: ",?14,$E(ECCN,1,26),?44,"Ord Section: "_$E(ECON,1,22)
W !,"Procedure: ",?14,$S(ECCPT="":"",1:ECPTCD_" ")_$E(ECPN,1,50)
W $S(SYN'["NOT DEFINED":" ["_SYN_"]",1:"")_" (#"_NATN_")"
I ECCPT'="" N MOD S MOD="" F S MOD=$O(ECMOD(ECCPT,MOD)) Q:MOD="" D
. W !?1,"Modifier: ",?18,"- ",MOD," ",$E($P(ECMOD(ECCPT,MOD),U),1,55)
;
;ALB/ESD - Display procedure reason
I +$G(ECPRPTR) S ECPRSL=$P($G(^ECL(+ECPRPTR,0)),"^") W !,"Procedure Reason: ",$P($G(^ECR(+ECPRSL,0)),"^")
W !,"Date: ",?14,ECDATE,?44,"Volume: "_ECV
W ! D DSP1444^ECPRVMUT(.ECPRVARY)
W !!!,"Is this information correct ? YES// " R ECYN:DTIME I '$T!(ECYN="^") D NOTE S ECOUT=2,CNT=0 K ECEC W "Press <RET> to continue " R X:DTIME Q
S ECYN=$E(ECYN) S:ECYN="" ECYN="Y"
I "YyNn"'[ECYN W !!,"Enter <RET> if the information listed above is correct and should be",!,"entered for the patients selected. Enter NO to re-enter the information",!,"for this procedure.",!
I "YyNn"'[ECYN W !!,"Press <RET> to continue " R X:DTIME G CHKP
I "Nn"[ECYN,$P(ECONE,"^")<2,$P(ECONE,"^",2)<2 S ECOUT=2 Q
I "Nn"[ECYN K ECHOICE,ECCN,ECP,ECPN,ECONE,ECMOD,^TMP("ECPRO",$J) G CHK
;
;ALB/ESD - File procedure reason in local array ECEC (used in ECBENF)
S COUNT=COUNT+1,ECEC(COUNT)=ECC_"^"_ECP_"^^"_ECO_"^"_ECV_"^^^^^^"_ECCPT_$S(+$G(ECPRPTR):"^"_ECPRPTR,1:"")
;File CPT modifiers in array ECEC if they exist
I ECCPT'="",$O(ECMOD(ECCPT,""))'="" D
. M ECEC(COUNT,"MOD")=ECMOD(ECCPT)
I $D(^TMP("ECPRO",$J,2)) W !! G P2
FILE ;file proc
I '$D(ECEC(1)) W !!,"No procedures have been selected for filing. Please re-enter the ",!,"information for the procedures, or ^ to exit.",!!,"Press <RET> to continue" R X:DTIME S:X="^" ECOUT=1 K ECTEMP,^TMP("ECPRO",$J) G P
D ^ECBEN2B
END Q
SETP ;set proc
S ECP=$P(^TMP("ECPRO",$J,CNT),"^"),ECPN=$P(^(CNT),"^",4),SYN=$P(^(CNT),"^",3),NATN=$P(^(CNT),"^",5),VOL=$P(^(CNT),"^",6)
S ECCPT=$S(ECP["EC":$P($G(^EC(725,+ECP,0)),"^",5),1:+ECP)
S ECPTCD="" I ECCPT'="" D
. S ECPTCD=$$CPT^ICPTCOD(ECCPT,ECDT) I +ECPTCD>0 S ECPTCD=$P(ECPTCD,U,2)
W " "_$S(ECCPT="":"",1:ECPTCD_" ")_$E(ECPN,1,50)
W $S(SYN'["NOT DEFINED":" ["_SYN_"]",1:"")_" (#"_NATN_")",!
S EC4=$P(^TMP("ECPRO",$J,CNT),"^",2)
S ^TMP("ECLKUP",$J,"LAST")=CNT
Q
SELC ; select category
W !!,$S(EC1:"Press",1:"Select Number, or press")_" <RET> to continue listing "_$S(EC1:"procedures",1:"categories")_" or '^' to stop: " R X:DTIME I '$T!(X="^") S (ECSTOP,ECHOICE)=1 Q
I X="" W @IOF,!,$S(EC1:"Available Procedures",1:"Categories")_" within ",ECDN," : ",! Q
I 'EC1,'$D(ECC(X)) D MSG1^ECBEN2U Q
I EC1,'$D(^TMP("ECPRO",$J,X)) D MSG1^ECBEN2U Q
S ECHOICE=1
I 'EC1 S ECC=$P(ECC(X),"^"),ECCN=$P(ECC(X),"^",2) Q
Q
NOTE ;
W !!,"**NOTE** No action taken.",!,"You must re-enter the correct patient and procedure data that",!,"has NOT been filed during this session. ",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECBEN2A 6458 printed Nov 22, 2024@17:07 Page 2
ECBEN2A ;BIR/MAM,JPW-Categories and Procedures Selection ;30 Apr 96
+1 ;;2.0; EVENT CAPTURE ;**1,4,5,13,18,33,47,72**;8 May 96
CHK ; check unit for valid categories
+1 SET (COUNT,EC1)=0
KILL ECHOICE,ECSTOP
+2 DO CATS^ECHECK1
SET ECONE=""
+3 IF '$DATA(ECC(1))
SET ECC=0
SET ECCN="None"
SET ECONE=0
GOTO P
+4 IF '$DATA(ECC(2))
SET ECC=+ECC(1)
SET ECCN=$PIECE(ECC(1),"^",2)
SET ECONE=1
GOTO P
CATS ; select category
+1 SET X=""
SET CNT=0
LIST DO HDR^ECBEN2U
SET JJ=0
WRITE !,"Categories within "_ECDN_": ",!
+1 SET EC1=0
+2 FOR
SET CNT=$ORDER(ECC(CNT))
if 'CNT!$DATA(ECHOICE)
QUIT
if ($Y+5>IOSL)
DO SELC
if $DATA(ECHOICE)
QUIT
IF X=""
WRITE !,CNT_".",?5,$PIECE(ECC(CNT),"^",2)
+3 IF '$DATA(ECSTOP)
IF $DATA(ECHOICE)
SET ECONE=2
GOTO P
PICK WRITE !!,"Select Number: "
READ X:DTIME
IF '$TEST!("^"[X)
SET ECOUT=1
QUIT
+1 IF '$DATA(ECC(X))
WRITE !!,"Select the number corresponding to the category, or ^ to quit.",!!,"Press <RET> to continue "
READ X:DTIME
SET CNT=CNT-5
SET X=""
GOTO LIST
+2 SET ECHOICE=1
SET ECC=$PIECE(ECC(X),"^")
SET ECCN=$PIECE(ECC(X),"^",2)
SET ECONE=2
P ;check for valid procedures
+1 KILL ^TMP("ECLKUP",$JOB)
+2 DO PROS^ECHECK1
+3 IF '$ORDER(^TMP("ECPRO",$JOB,0))
Begin DoDot:1
+4 WRITE !!,"Within the ",ECLN," location there are no procedures defined",!
+5 WRITE "for the DSS Unit ",ECDN,". Please select another DSS Unit.",!!
+6 WRITE "Press <RET> to continue "
READ X:DTIME
SET ECOUT=2
QUIT
End DoDot:1
if ECOUT
QUIT
+7 DO HDR^ECBEN2U
P1 ;
+1 IF '$DATA(^TMP("ECPRO",$JOB,2))
SET CNT=1
SET ECONE=ECONE_"^1"
DO SETP
WRITE !,"Procedure: "
Begin DoDot:1
+2 WRITE $SELECT(ECCPT="":"",1:ECPTCD_" ")_$EXTRACT(ECPN,1,50)
+3 WRITE $SELECT(SYN'["NOT DEFINED":" ["_SYN_"]",1:"")_" (#"_NATN_")",!
End DoDot:1
GOTO V
P2 ;ask mul proc
+1 SET ECX=""
SET (ECPCNT,CNT,OK)=0
SET EC1=1
KILL ECHOICE,ECSTOP,ECMOD
+2 SET DIR("?")="^D PROS^ECBEN2A"
+3 SET ECX=$$GETPRO^ECDSUTIL
+4 IF +$GET(ECX)=-1
IF (COUNT=0)
DO MSG^ECBEN2U
DO KILLV^ECDSUTIL
QUIT
+5 IF +$GET(ECX)=-1
IF COUNT
GOTO FILE
+6 IF +$GET(ECX)=1
DO SRCHTM^ECDSUTIL(ECX)
+7 SET ECPCNT=+$GET(ECPCNT)
+8 IF ECPCNT=-1!(ECPCNT=-2)
Begin DoDot:1
+9 DO @($SELECT(ECPCNT=-1:"ERRMSG^ECDSUTIL",ECPCNT=-2:"ERRMSG2^ECDSUTIL"))
+10 DO KILLV^ECDSUTIL
End DoDot:1
GOTO P2
+11 IF ECPCNT>0
Begin DoDot:1
+12 SET CNT=ECPCNT
+13 DO SETP
+14 SET OK=1
SET ECONE=ECONE_"^2"
+15 DO KILLV^ECDSUTIL
End DoDot:1
GOTO V
+16 IF 'ECPCNT
IF $DATA(ECPNAME)
SET CNT=$$PRLST^ECDSUTIL
+17 IF CNT=-1
DO MSG^ECBEN2U
DO KILLV^ECDSUTIL
QUIT
+18 IF CNT>0
Begin DoDot:1
+19 DO SETP
+20 SET OK=1
SET ECONE=ECONE_"^2"
+21 DO KILLV^ECDSUTIL
End DoDot:1
GOTO V
+22 QUIT
+23 ;
PROS ;
+1 SET X=""
SET CNT=0
KILL ECHOICE
LISTP DO HDR^ECBEN2U
SET JJ=1
WRITE !,"Available Procedures within "_ECDN_": ",!
+1 WRITE ?72,"National",!,?5,"Procedure Name",?40,"Synonym",?72,"Number",!
+2 SET EC1=1
+3 FOR
SET CNT=$ORDER(^TMP("ECPRO",$JOB,CNT))
if 'CNT!$DATA(ECHOICE)
QUIT
if ($Y+5>IOSL)
DO SELC
if $DATA(ECHOICE)
QUIT
IF X=""
WRITE !,CNT_".",?5,$EXTRACT($PIECE(^TMP("ECPRO",$JOB,CNT),"^",4),1,30),?38,$EXTRACT($PIECE(^(CNT),"^",3),1,30),?72,$PIECE(^(CNT),"^",5)
+4 IF X=""
Begin DoDot:1
+5 WRITE !!?5,"Select by number, CPT or national code, procedure name, or synonym."
+6 WRITE !?5,"Synonym must be preceded by the & character (example: &TESTSYN).",!
+7 WRITE ?2,"** Modifier(s) can be appended to a CPT code (ex: CPT code-mod1,mod2,mod3) **",!
End DoDot:1
+8 QUIT
+9 ;
V ;vol (and procedure reason),ask for CPT modifier is applicable
+1 ;
+2 ;ALB/JAM - Ask CPT Procedure Modifier
+3 IF ECCPT'=""
Begin DoDot:1
+4 SET ECMODS=$GET(ECMODS)
+5 SET ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.ECERR)
+6 IF $GET(ECERR)
SET ECOUT=1
+7 KILL ECMODF,ECMODS
End DoDot:1
IF ECOUT
QUIT
+8 ;ALB/ESD - Ask Procedure Reason
+9 IF $GET(ECP)]""
SET ECSCR=+$ORDER(^ECJ("AP",+ECL,+ECD,+ECC,ECP,0))
+10 KILL ECPRPTR
+11 IF ECSCR>0
IF ($PIECE($GET(^ECJ(ECSCR,"PRO")),"^",5)=1)
IF (+$ORDER(^ECL("AD",ECSCR,0)))
Begin DoDot:1
+12 SET ECPRPTR=0
+13 SET DIC="^ECL("
SET DIC(0)="QEAM"
+14 SET DIC("A")="Procedure Reason: "
SET DIC("S")="I $P(^(0),U,2)=ECSCR"
+15 DO ^DIC
KILL DIC
+16 IF +Y>0
SET ECPRPTR=+Y
End DoDot:1
+17 KILL ECSCR
+18 ;
VV ;vol
+1 if 'VOL
SET VOL=1
+2 WRITE !,"Volume: "_VOL_"// "
READ X:DTIME
IF '$TEST
SET ECOUT=1
QUIT
+3 IF X="^"
SET ECOUT=1
QUIT
+4 if X=""
SET X=VOL
IF X'?1.2N!'X
WRITE !!,"Enter a whole number between 1 and 99."
GOTO VV
+5 SET ECV=X
CHKP ;
+1 WRITE !!,"Category: ",?14,$EXTRACT(ECCN,1,26),?44,"Ord Section: "_$EXTRACT(ECON,1,22)
+2 WRITE !,"Procedure: ",?14,$SELECT(ECCPT="":"",1:ECPTCD_" ")_$EXTRACT(ECPN,1,50)
+3 WRITE $SELECT(SYN'["NOT DEFINED":" ["_SYN_"]",1:"")_" (#"_NATN_")"
+4 IF ECCPT'=""
NEW MOD
SET MOD=""
FOR
SET MOD=$ORDER(ECMOD(ECCPT,MOD))
if MOD=""
QUIT
Begin DoDot:1
+5 WRITE !?1,"Modifier: ",?18,"- ",MOD," ",$EXTRACT($PIECE(ECMOD(ECCPT,MOD),U),1,55)
End DoDot:1
+6 ;
+7 ;ALB/ESD - Display procedure reason
+8 IF +$GET(ECPRPTR)
SET ECPRSL=$PIECE($GET(^ECL(+ECPRPTR,0)),"^")
WRITE !,"Procedure Reason: ",$PIECE($GET(^ECR(+ECPRSL,0)),"^")
+9 WRITE !,"Date: ",?14,ECDATE,?44,"Volume: "_ECV
+10 WRITE !
DO DSP1444^ECPRVMUT(.ECPRVARY)
+11 WRITE !!!,"Is this information correct ? YES// "
READ ECYN:DTIME
IF '$TEST!(ECYN="^")
DO NOTE
SET ECOUT=2
SET CNT=0
KILL ECEC
WRITE "Press <RET> to continue "
READ X:DTIME
QUIT
+12 SET ECYN=$EXTRACT(ECYN)
if ECYN=""
SET ECYN="Y"
+13 IF "YyNn"'[ECYN
WRITE !!,"Enter <RET> if the information listed above is correct and should be",!,"entered for the patients selected. Enter NO to re-enter the information",!,"for this procedure.",!
+14 IF "YyNn"'[ECYN
WRITE !!,"Press <RET> to continue "
READ X:DTIME
GOTO CHKP
+15 IF "Nn"[ECYN
IF $PIECE(ECONE,"^")<2
IF $PIECE(ECONE,"^",2)<2
SET ECOUT=2
QUIT
+16 IF "Nn"[ECYN
KILL ECHOICE,ECCN,ECP,ECPN,ECONE,ECMOD,^TMP("ECPRO",$JOB)
GOTO CHK
+17 ;
+18 ;ALB/ESD - File procedure reason in local array ECEC (used in ECBENF)
+19 SET COUNT=COUNT+1
SET ECEC(COUNT)=ECC_"^"_ECP_"^^"_ECO_"^"_ECV_"^^^^^^"_ECCPT_$SELECT(+$GET(ECPRPTR):"^"_ECPRPTR,1:"")
+20 ;File CPT modifiers in array ECEC if they exist
+21 IF ECCPT'=""
IF $ORDER(ECMOD(ECCPT,""))'=""
Begin DoDot:1
+22 MERGE ECEC(COUNT,"MOD")=ECMOD(ECCPT)
End DoDot:1
+23 IF $DATA(^TMP("ECPRO",$JOB,2))
WRITE !!
GOTO P2
FILE ;file proc
+1 IF '$DATA(ECEC(1))
WRITE !!,"No procedures have been selected for filing. Please re-enter the ",!,"information for the procedures, or ^ to exit.",!!,"Press <RET> to continue"
READ X:DTIME
if X="^"
SET ECOUT=1
KILL ECTEMP,^TMP("ECPRO",$JOB)
GOTO P
+2 DO ^ECBEN2B
END QUIT
SETP ;set proc
+1 SET ECP=$PIECE(^TMP("ECPRO",$JOB,CNT),"^")
SET ECPN=$PIECE(^(CNT),"^",4)
SET SYN=$PIECE(^(CNT),"^",3)
SET NATN=$PIECE(^(CNT),"^",5)
SET VOL=$PIECE(^(CNT),"^",6)
+2 SET ECCPT=$SELECT(ECP["EC":$PIECE($GET(^EC(725,+ECP,0)),"^",5),1:+ECP)
+3 SET ECPTCD=""
IF ECCPT'=""
Begin DoDot:1
+4 SET ECPTCD=$$CPT^ICPTCOD(ECCPT,ECDT)
IF +ECPTCD>0
SET ECPTCD=$PIECE(ECPTCD,U,2)
End DoDot:1
+5 WRITE " "_$SELECT(ECCPT="":"",1:ECPTCD_" ")_$EXTRACT(ECPN,1,50)
+6 WRITE $SELECT(SYN'["NOT DEFINED":" ["_SYN_"]",1:"")_" (#"_NATN_")",!
+7 SET EC4=$PIECE(^TMP("ECPRO",$JOB,CNT),"^",2)
+8 SET ^TMP("ECLKUP",$JOB,"LAST")=CNT
+9 QUIT
SELC ; select category
+1 WRITE !!,$SELECT(EC1:"Press",1:"Select Number, or press")_" <RET> to continue listing "_$SELECT(EC1:"procedures",1:"categories")_" or '^' to stop: "
READ X:DTIME
IF '$TEST!(X="^")
SET (ECSTOP,ECHOICE)=1
QUIT
+2 IF X=""
WRITE @IOF,!,$SELECT(EC1:"Available Procedures",1:"Categories")_" within ",ECDN," : ",!
QUIT
+3 IF 'EC1
IF '$DATA(ECC(X))
DO MSG1^ECBEN2U
QUIT
+4 IF EC1
IF '$DATA(^TMP("ECPRO",$JOB,X))
DO MSG1^ECBEN2U
QUIT
+5 SET ECHOICE=1
+6 IF 'EC1
SET ECC=$PIECE(ECC(X),"^")
SET ECCN=$PIECE(ECC(X),"^",2)
QUIT
+7 QUIT
NOTE ;
+1 WRITE !!,"**NOTE** No action taken.",!,"You must re-enter the correct patient and procedure data that",!,"has NOT been filed during this session. ",!!
+2 QUIT
