ECDSUTIL ;BIR/RHK,TTH - Event Capture Utilities ;4 May 95
;;2.0; EVENT CAPTURE ;**4,5,7,14,18,29**;8 May 96
;Routine of various utilities and common subroutines
UNIT ;Select DSS Unit
I '$D(ECL) D ^ECL Q:'$D(ECL)
S CNT=0 F XX=0:0 S XX=$O(^ECJ("AP",ECL,XX)) Q:'XX S CNT=CNT+1 S ECD=XX
I CNT<2 D G SETVAR
.S ECDN=$P(^ECD(ECD,0),"^") W !,"DSS Unit: ",ECDN
.S Y=ECD_"^"_$P(^ECD(ECD,0),"^")
.S Y(0)=^ECD(ECD,0)
.Q
S DIC=724,DIC(0)="AEQMZ",DIC("A")="Select DSS Unit: ",DIC("S")="I $D(^ECJ(""AP"",ECL,+Y))" D ^DIC K DIC I Y<0 K ECL Q
S ECD=+Y,ECDN=$P(Y,U,2)
SETVAR ;Set variable from the selected DSS Unit.
S ECD(0)=Y(0),ECS=$P(Y(0),U,2),ECMS=$P(Y(0),U,3),ECOST=$P(Y(0),U,4),ECSN=$P(^DIC(49,ECS,0),U)
S ECPCE="U~"_$S($P(ECD(0),U,14)]"":$P(ECD(0),"^",14),1:"N")
I $P(^ECD(ECD,0),U,11) D I $D(ECERR) K ECL,ECD,ECS,ECMS,ECOST,ECSN Q
.S DIC=726,DIC(0)="AEQMZ",DIC("A")="Select Category: ",DIC("S")="I $D(^ECJ(""AP"",ECL,ECD,+Y))&('$P(^EC(726,+Y,0),U,3)!($P(^EC(726,+Y,0),U,3)>DT))"
.D ^DIC K DIC I Y<0 S ECERR=1 Q
.S ECC=+Y,ECCN=Y(0,0)
I '$D(ECC) S ECC=0,ECCN="None"
Q
;
;
;ALB/ESD - Procedure Reason utilities
;
ADREAS(ECSPTR) ; Add procedure reason(s) to the EC Procedure Reason (#720.4)
; file and pointers to the EC Event Code Screens/Proc Reason
; Link (#720.5) file
;
N DA,DIC,DLAYGO,DIE,DR,ECPRPTR,X,Y,DUOUT,DTOUT
ASK S ECSPTR=+$G(ECSPTR)
I 'ECSPTR G ADREASQ
S DIC="^ECR(",DIC(0)="QEALZ",DLAYGO=720.4,DIC("A")="Enter procedure reason: "
D ^DIC
Q:Y=-1 Q:($D(DUOUT)!$D(DTOUT))
I +Y>0 D
. S ECPRPTR=+Y
. S DIE=DIC,DA=ECPRPTR,DR=".02////1" D ^DIE
. K DA,DIC,DLAYGO,DIE,Y
. I '$D(^ECL("AC",ECPRPTR,ECSPTR)) D
.. S DIC="^ECL(",DIC(0)="L",DLAYGO=720.5,X=ECPRPTR,DIC("DR")=".02////"_ECSPTR
.. K DD,DO D FILE^DICN
G ASK
ADREASQ Q
;
;
GETSCRN(ECPPTR) ; Get EC Event Code Screens (#720.3) file internal entry number
; (IEN)
;
; Input: ECPPTR = Event Capture Patient (#721) file IEN
;
; Output: EC Event Code Screens IEN if found or zero if not
;
I '$G(ECPPTR) G GETSCRNQ
N ECSIEN,ECNODE0
S ECSIEN=0,ECNODE0=""
;
;- Get EC Patient record zero node
S ECNODE0=$G(^ECH(+ECPPTR,0))
I ECNODE0="" G GETSCRNQ
;
;- Get EC Screen IEN from file #720.3 "AP" xref using Loc, DSS Unit,
; Category, and Procedure from EC Patient record
S ECSIEN=+$O(^ECJ("AP",+$P(ECNODE0,U,4),+$P(ECNODE0,U,7),+$P(ECNODE0,U,8),$P(ECNODE0,U,9),0))
I 'ECSIEN G GETSCRNQ
;
;- If 'Ask Procedure Reasons?' field = Yes and one or more procedure
; reasons entered for the event code screen
S ECSIEN=$S((+$P($G(^ECJ(ECSIEN,"PRO")),U,5))&(+$O(^ECL("AD",ECSIEN,0))):ECSIEN,1:0)
GETSCRNQ Q +$G(ECSIEN)
;
;
GETPRO() ;Get procedure from user and determine type
; Input: None
; Output: 1^type of procedure: X = procedure number
; N = CPT or national number
; A = name of procedure
; S = procedure synonym
; or -1 if unsuccessful
;
; ECPROCED = value of Y from DIR call
; ECMODS = value of CPT modifiers separated by comman
;
N ECANS,Y
K ECMODS S ECMODS="",ECANS=-1
S DIR(0)="FAO",DIR("A")="Enter Procedure: "
D ^DIR
I $D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(Y="") G GETPROQ
I $G(Y)]"" D
. S ECANS=$S($P(Y,"-")?1.4N:"X",($L($P(Y,"-"))=5)&(($P(Y,"-")?5N)!($P(Y,"-")?1A4AN)):"N",((Y?1A.ANP)&($E(Y,1)'="&")):"A",(Y?1"&".ANP):"S",($A(Y)=32):"L",(($L(Y)>5)&(Y?1N.ANP)):"A",1:"ERR")
. ;S ECANS=$S(Y?1.4N:"X",($L(Y)=5)&((Y?5N)!(Y?1A4AN)):"N",((Y?1A.ANP)&($E(Y,1)'="&")):"A",(Y?1"&".ANP):"S",($A(Y)=32):"L",(($L(Y)>5)&(Y?1N.ANP)):"A",1:"ERR")
. I ECANS'="ERR" D
.. I "X^N^"[ECANS S ECMODS=$P(Y,"-",2),Y=$P(Y,"-")
.. S ECMODS=$TR(ECMODS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.. S ECANS=1_"^"_ECANS
.. S ECPROCED=Y I $E(ECPROCED,1)="&" S ECPROCED=$E(ECPROCED,2,$L(ECPROCED))
. I ECANS="ERR" S ECANS=-1
;
GETPROQ K DIR,DIRUT,DTOUT,DUOUT
Q $G(ECANS)
;
;
SRCHTM(ANS) ; Lookup for procedures in ^TMP("ECPRO",$J)
; Input: Procedure type (see first output in GETPRO function above)
; Output: ECPCNT: -1 = no (or bad) procedure type
; 0 = procedure is in local ECPNAME array
; (for A and S types)
; number = procedure number (for X and N types)
;
; ECPNAME = procedure number^procedure name
; (for A and S types)
;
N ECNOGO,ECPNAM,ECPUNAM,I,J
S ECPCNT=-1,ECPNAM="",J=0
I +ANS=-1!($G(ANS)="") G SRCHTMQ
I +ANS=1,('$D(ECPROCED)) S ANS=-1 G SRCHTMQ
;
;-- Get 2nd piece of procedure type (letter) for lookup
S ANS=$P(ANS,"^",2)
;
;-- Convert to upper case to handle case sensitivity
S ECPROCED=$$UPPER^VALM1(ECPROCED)
;
;-- X = procedure number
I ANS="X",$D(^TMP("ECPRO",$J,ECPROCED)) S ECPCNT=ECPROCED G SRCHTMQ
;
;-- N = CPT or national number
I ANS="N",(+$O(^TMP("ECPRO",$J,"N",ECPROCED,0))>0) S ECPCNT=+$O(^TMP("ECPRO",$J,"N",ECPROCED,0)) G SRCHTMQ
;
;-- If "N" and not in National # xref, chk to see if it's a proc name
I ANS="N",(+$O(^TMP("ECPRO",$J,"N",ECPROCED,0))=0) S ANS="A"
;
;-- L = last procedure (spacebar/return functionality)
I ANS="L",$D(^TMP("ECLKUP",$J,"LAST")) S ECPCNT=+$P($G(^TMP("ECLKUP",$J,"LAST")),"^") G SRCHTMQ
;
;-- A = name of procedure / S = procedure synonym
I ANS="A"!(ANS="S") D
. F S ECPNAM=$O(^TMP("ECPRO",$J,$S(ANS="A":"B",ANS="S":"SYN"),ECPNAM)) Q:ECPNAM="" D
.. S ECNOGO=0
.. S ECPUNAM=$$UPPER^VALM1(ECPNAM)
.. F I=1:1:$L(ECPROCED) S:$E(ECPROCED,I)'=$E(ECPUNAM,I) ECNOGO=1
.. I 'ECNOGO S J=J+1,ECPCNT=0,ECPNAME(J)=+$O(^TMP("ECPRO",$J,$S(ANS="A":"B",ANS="S":"SYN"),ECPNAM,0))_"^"_ECPNAM
I ANS="L",'$D(^TMP("ECLKUP",$J,"LAST")) S ECPCNT=-2
SRCHTMQ Q
;
;
PRLST() ;Print list if more than one procedure matches
;
N ECFL,ECRESP,ECMAX,I
S (ECFL,ECRESP,ECMAX,I)=0
G:'$D(ECPNAME) PRLSTQ
F S I=$O(ECPNAME(I)) Q:'I!(ECFL) D
. I '$D(ECPNAME(2)) S (ECFL,ECRESP)=1 Q
. W !?5,I,?10,$P(ECPNAME(I),"^",2) S ECMAX=I
G:ECFL PRLSTQ
CHOOSE S ECRESP=0
W !!,"CHOOSE 1-"_ECMAX_": " R ECRESP:DTIME I '$T!(ECRESP["^") G PRLSTQ
I +ECRESP<1!(+ECRESP>ECMAX) W *7,"??" G CHOOSE
PRLSTQ Q $S(ECRESP>0:+$P(ECPNAME(ECRESP),"^"),1:-1)
;
;
;
ERRMSG ;Invalid procedure error message
;
W !!,"Enter a valid procedure or press ""^"" to exit.",!
Q
;
;
ERRMSG2 ;Spacebar/return error message
;
W !!?5,"One procedure must be entered before using spacebar/return",!?5,"to get the same procedure.",!
Q
;
;
KILLV ;
K ECPCNT,ECPNAME,ECPROCED,ECPROS,ECX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECDSUTIL 6729 printed Oct 16, 2024@17:58 Page 2
ECDSUTIL ;BIR/RHK,TTH - Event Capture Utilities ;4 May 95
+1 ;;2.0; EVENT CAPTURE ;**4,5,7,14,18,29**;8 May 96
+2 ;Routine of various utilities and common subroutines
UNIT ;Select DSS Unit
+1 IF '$DATA(ECL)
DO ^ECL
if '$DATA(ECL)
QUIT
+2 SET CNT=0
FOR XX=0:0
SET XX=$ORDER(^ECJ("AP",ECL,XX))
if 'XX
QUIT
SET CNT=CNT+1
SET ECD=XX
+3 IF CNT<2
Begin DoDot:1
+4 SET ECDN=$PIECE(^ECD(ECD,0),"^")
WRITE !,"DSS Unit: ",ECDN
+5 SET Y=ECD_"^"_$PIECE(^ECD(ECD,0),"^")
+6 SET Y(0)=^ECD(ECD,0)
+7 QUIT
End DoDot:1
GOTO SETVAR
+8 SET DIC=724
SET DIC(0)="AEQMZ"
SET DIC("A")="Select DSS Unit: "
SET DIC("S")="I $D(^ECJ(""AP"",ECL,+Y))"
DO ^DIC
KILL DIC
IF Y<0
KILL ECL
QUIT
+9 SET ECD=+Y
SET ECDN=$PIECE(Y,U,2)
SETVAR ;Set variable from the selected DSS Unit.
+1 SET ECD(0)=Y(0)
SET ECS=$PIECE(Y(0),U,2)
SET ECMS=$PIECE(Y(0),U,3)
SET ECOST=$PIECE(Y(0),U,4)
SET ECSN=$PIECE(^DIC(49,ECS,0),U)
+2 SET ECPCE="U~"_$SELECT($PIECE(ECD(0),U,14)]"":$PIECE(ECD(0),"^",14),1:"N")
+3 IF $PIECE(^ECD(ECD,0),U,11)
Begin DoDot:1
+4 SET DIC=726
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Category: "
SET DIC("S")="I $D(^ECJ(""AP"",ECL,ECD,+Y))&('$P(^EC(726,+Y,0),U,3)!($P(^EC(726,+Y,0),U,3)>DT))"
+5 DO ^DIC
KILL DIC
IF Y<0
SET ECERR=1
QUIT
+6 SET ECC=+Y
SET ECCN=Y(0,0)
End DoDot:1
IF $DATA(ECERR)
KILL ECL,ECD,ECS,ECMS,ECOST,ECSN
QUIT
+7 IF '$DATA(ECC)
SET ECC=0
SET ECCN="None"
+8 QUIT
+9 ;
+10 ;
+11 ;ALB/ESD - Procedure Reason utilities
+12 ;
ADREAS(ECSPTR) ; Add procedure reason(s) to the EC Procedure Reason (#720.4)
+1 ; file and pointers to the EC Event Code Screens/Proc Reason
+2 ; Link (#720.5) file
+3 ;
+4 NEW DA,DIC,DLAYGO,DIE,DR,ECPRPTR,X,Y,DUOUT,DTOUT
ASK SET ECSPTR=+$GET(ECSPTR)
+1 IF 'ECSPTR
GOTO ADREASQ
+2 SET DIC="^ECR("
SET DIC(0)="QEALZ"
SET DLAYGO=720.4
SET DIC("A")="Enter procedure reason: "
+3 DO ^DIC
+4 if Y=-1
QUIT
if ($DATA(DUOUT)!$DATA(DTOUT))
QUIT
+5 IF +Y>0
Begin DoDot:1
+6 SET ECPRPTR=+Y
+7 SET DIE=DIC
SET DA=ECPRPTR
SET DR=".02////1"
DO ^DIE
+8 KILL DA,DIC,DLAYGO,DIE,Y
+9 IF '$DATA(^ECL("AC",ECPRPTR,ECSPTR))
Begin DoDot:2
+10 SET DIC="^ECL("
SET DIC(0)="L"
SET DLAYGO=720.5
SET X=ECPRPTR
SET DIC("DR")=".02////"_ECSPTR
+11 KILL DD,DO
DO FILE^DICN
End DoDot:2
End DoDot:1
+12 GOTO ASK
ADREASQ QUIT
+1 ;
+2 ;
GETSCRN(ECPPTR) ; Get EC Event Code Screens (#720.3) file internal entry number
+1 ; (IEN)
+2 ;
+3 ; Input: ECPPTR = Event Capture Patient (#721) file IEN
+4 ;
+5 ; Output: EC Event Code Screens IEN if found or zero if not
+6 ;
+7 IF '$GET(ECPPTR)
GOTO GETSCRNQ
+8 NEW ECSIEN,ECNODE0
+9 SET ECSIEN=0
SET ECNODE0=""
+10 ;
+11 ;- Get EC Patient record zero node
+12 SET ECNODE0=$GET(^ECH(+ECPPTR,0))
+13 IF ECNODE0=""
GOTO GETSCRNQ
+14 ;
+15 ;- Get EC Screen IEN from file #720.3 "AP" xref using Loc, DSS Unit,
+16 ; Category, and Procedure from EC Patient record
+17 SET ECSIEN=+$ORDER(^ECJ("AP",+$PIECE(ECNODE0,U,4),+$PIECE(ECNODE0,U,7),+$PIECE(ECNODE0,U,8),$PIECE(ECNODE0,U,9),0))
+18 IF 'ECSIEN
GOTO GETSCRNQ
+19 ;
+20 ;- If 'Ask Procedure Reasons?' field = Yes and one or more procedure
+21 ; reasons entered for the event code screen
+22 SET ECSIEN=$SELECT((+$PIECE($GET(^ECJ(ECSIEN,"PRO")),U,5))&(+$ORDER(^ECL("AD",ECSIEN,0))):ECSIEN,1:0)
GETSCRNQ QUIT +$GET(ECSIEN)
+1 ;
+2 ;
GETPRO() ;Get procedure from user and determine type
+1 ; Input: None
+2 ; Output: 1^type of procedure: X = procedure number
+3 ; N = CPT or national number
+4 ; A = name of procedure
+5 ; S = procedure synonym
+6 ; or -1 if unsuccessful
+7 ;
+8 ; ECPROCED = value of Y from DIR call
+9 ; ECMODS = value of CPT modifiers separated by comman
+10 ;
+11 NEW ECANS,Y
+12 KILL ECMODS
SET ECMODS=""
SET ECANS=-1
+13 SET DIR(0)="FAO"
SET DIR("A")="Enter Procedure: "
+14 DO ^DIR
+15 IF $DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT))!(Y="")
GOTO GETPROQ
+16 IF $GET(Y)]""
Begin DoDot:1
+17 SET ECANS=$SELECT($PIECE(Y,"-")?1.4N:"X",($LENGTH($PIECE(Y,"-"))=5)&(($PIECE(Y,"-")?5N)!($PIECE(Y,"-")?1A4AN)):"N",((Y?1A.ANP)&($EXTRACT(Y,1)'="&")):"A",(Y?1"&".ANP):"S",($ASCII(Y)=32):"L",(($LENGTH(Y)>5)&(Y?1N.ANP)):"A",1:"ERR")
+18 ;S ECANS=$S(Y?1.4N:"X",($L(Y)=5)&((Y?5N)!(Y?1A4AN)):"N",((Y?1A.ANP)&($E(Y,1)'="&")):"A",(Y?1"&".ANP):"S",($A(Y)=32):"L",(($L(Y)>5)&(Y?1N.ANP)):"A",1:"ERR")
+19 IF ECANS'="ERR"
Begin DoDot:2
+20 IF "X^N^"[ECANS
SET ECMODS=$PIECE(Y,"-",2)
SET Y=$PIECE(Y,"-")
+21 SET ECMODS=$TRANSLATE(ECMODS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+22 SET ECANS=1_"^"_ECANS
+23 SET ECPROCED=Y
IF $EXTRACT(ECPROCED,1)="&"
SET ECPROCED=$EXTRACT(ECPROCED,2,$LENGTH(ECPROCED))
End DoDot:2
+24 IF ECANS="ERR"
SET ECANS=-1
End DoDot:1
+25 ;
GETPROQ KILL DIR,DIRUT,DTOUT,DUOUT
+1 QUIT $GET(ECANS)
+2 ;
+3 ;
SRCHTM(ANS) ; Lookup for procedures in ^TMP("ECPRO",$J)
+1 ; Input: Procedure type (see first output in GETPRO function above)
+2 ; Output: ECPCNT: -1 = no (or bad) procedure type
+3 ; 0 = procedure is in local ECPNAME array
+4 ; (for A and S types)
+5 ; number = procedure number (for X and N types)
+6 ;
+7 ; ECPNAME = procedure number^procedure name
+8 ; (for A and S types)
+9 ;
+10 NEW ECNOGO,ECPNAM,ECPUNAM,I,J
+11 SET ECPCNT=-1
SET ECPNAM=""
SET J=0
+12 IF +ANS=-1!($GET(ANS)="")
GOTO SRCHTMQ
+13 IF +ANS=1
IF ('$DATA(ECPROCED))
SET ANS=-1
GOTO SRCHTMQ
+14 ;
+15 ;-- Get 2nd piece of procedure type (letter) for lookup
+16 SET ANS=$PIECE(ANS,"^",2)
+17 ;
+18 ;-- Convert to upper case to handle case sensitivity
+19 SET ECPROCED=$$UPPER^VALM1(ECPROCED)
+20 ;
+21 ;-- X = procedure number
+22 IF ANS="X"
IF $DATA(^TMP("ECPRO",$JOB,ECPROCED))
SET ECPCNT=ECPROCED
GOTO SRCHTMQ
+23 ;
+24 ;-- N = CPT or national number
+25 IF ANS="N"
IF (+$ORDER(^TMP("ECPRO",$JOB,"N",ECPROCED,0))>0)
SET ECPCNT=+$ORDER(^TMP("ECPRO",$JOB,"N",ECPROCED,0))
GOTO SRCHTMQ
+26 ;
+27 ;-- If "N" and not in National # xref, chk to see if it's a proc name
+28 IF ANS="N"
IF (+$ORDER(^TMP("ECPRO",$JOB,"N",ECPROCED,0))=0)
SET ANS="A"
+29 ;
+30 ;-- L = last procedure (spacebar/return functionality)
+31 IF ANS="L"
IF $DATA(^TMP("ECLKUP",$JOB,"LAST"))
SET ECPCNT=+$PIECE($GET(^TMP("ECLKUP",$JOB,"LAST")),"^")
GOTO SRCHTMQ
+32 ;
+33 ;-- A = name of procedure / S = procedure synonym
+34 IF ANS="A"!(ANS="S")
Begin DoDot:1
+35 FOR
SET ECPNAM=$ORDER(^TMP("ECPRO",$JOB,$SELECT(ANS="A":"B",ANS="S":"SYN"),ECPNAM))
if ECPNAM=""
QUIT
Begin DoDot:2
+36 SET ECNOGO=0
+37 SET ECPUNAM=$$UPPER^VALM1(ECPNAM)
+38 FOR I=1:1:$LENGTH(ECPROCED)
if $EXTRACT(ECPROCED,I)'=$EXTRACT(ECPUNAM,I)
SET ECNOGO=1
+39 IF 'ECNOGO
SET J=J+1
SET ECPCNT=0
SET ECPNAME(J)=+$ORDER(^TMP("ECPRO",$JOB,$SELECT(ANS="A":"B",ANS="S":"SYN"),ECPNAM,0))_"^"_ECPNAM
End DoDot:2
End DoDot:1
+40 IF ANS="L"
IF '$DATA(^TMP("ECLKUP",$JOB,"LAST"))
SET ECPCNT=-2
SRCHTMQ QUIT
+1 ;
+2 ;
PRLST() ;Print list if more than one procedure matches
+1 ;
+2 NEW ECFL,ECRESP,ECMAX,I
+3 SET (ECFL,ECRESP,ECMAX,I)=0
+4 if '$DATA(ECPNAME)
GOTO PRLSTQ
+5 FOR
SET I=$ORDER(ECPNAME(I))
if 'I!(ECFL)
QUIT
Begin DoDot:1
+6 IF '$DATA(ECPNAME(2))
SET (ECFL,ECRESP)=1
QUIT
+7 WRITE !?5,I,?10,$PIECE(ECPNAME(I),"^",2)
SET ECMAX=I
End DoDot:1
+8 if ECFL
GOTO PRLSTQ
CHOOSE SET ECRESP=0
+1 WRITE !!,"CHOOSE 1-"_ECMAX_": "
READ ECRESP:DTIME
IF '$TEST!(ECRESP["^")
GOTO PRLSTQ
+2 IF +ECRESP<1!(+ECRESP>ECMAX)
WRITE *7,"??"
GOTO CHOOSE
PRLSTQ QUIT $SELECT(ECRESP>0:+$PIECE(ECPNAME(ECRESP),"^"),1:-1)
+1 ;
+2 ;
+3 ;
ERRMSG ;Invalid procedure error message
+1 ;
+2 WRITE !!,"Enter a valid procedure or press ""^"" to exit.",!
+3 QUIT
+4 ;
+5 ;
ERRMSG2 ;Spacebar/return error message
+1 ;
+2 WRITE !!?5,"One procedure must be entered before using spacebar/return",!?5,"to get the same procedure.",!
+3 QUIT
+4 ;
+5 ;
KILLV ;
+1 KILL ECPCNT,ECPNAME,ECPROCED,ECPROS,ECX
+2 QUIT
