| [613] | 1 | ECDSUTIL ;BIR/RHK,TTH - Event Capture Utilities ;4 May 95
|
|---|
| 2 | ;;2.0; EVENT CAPTURE ;**4,5,7,14,18,29**;8 May 96
|
|---|
| 3 | ;Routine of various utilities and common subroutines
|
|---|
| 4 | UNIT ;Select DSS Unit
|
|---|
| 5 | I '$D(ECL) D ^ECL Q:'$D(ECL)
|
|---|
| 6 | S CNT=0 F XX=0:0 S XX=$O(^ECJ("AP",ECL,XX)) Q:'XX S CNT=CNT+1 S ECD=XX
|
|---|
| 7 | I CNT<2 D G SETVAR
|
|---|
| 8 | .S ECDN=$P(^ECD(ECD,0),"^") W !,"DSS Unit: ",ECDN
|
|---|
| 9 | .S Y=ECD_"^"_$P(^ECD(ECD,0),"^")
|
|---|
| 10 | .S Y(0)=^ECD(ECD,0)
|
|---|
| 11 | .Q
|
|---|
| 12 | 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
|
|---|
| 13 | S ECD=+Y,ECDN=$P(Y,U,2)
|
|---|
| 14 | SETVAR ;Set variable from the selected DSS Unit.
|
|---|
| 15 | 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)
|
|---|
| 16 | S ECPCE="U~"_$S($P(ECD(0),U,14)]"":$P(ECD(0),"^",14),1:"N")
|
|---|
| 17 | I $P(^ECD(ECD,0),U,11) D I $D(ECERR) K ECL,ECD,ECS,ECMS,ECOST,ECSN Q
|
|---|
| 18 | .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))"
|
|---|
| 19 | .D ^DIC K DIC I Y<0 S ECERR=1 Q
|
|---|
| 20 | .S ECC=+Y,ECCN=Y(0,0)
|
|---|
| 21 | I '$D(ECC) S ECC=0,ECCN="None"
|
|---|
| 22 | Q
|
|---|
| 23 | ;
|
|---|
| 24 | ;
|
|---|
| 25 | ;ALB/ESD - Procedure Reason utilities
|
|---|
| 26 | ;
|
|---|
| 27 | ADREAS(ECSPTR) ; Add procedure reason(s) to the EC Procedure Reason (#720.4)
|
|---|
| 28 | ; file and pointers to the EC Event Code Screens/Proc Reason
|
|---|
| 29 | ; Link (#720.5) file
|
|---|
| 30 | ;
|
|---|
| 31 | N DA,DIC,DLAYGO,DIE,DR,ECPRPTR,X,Y,DUOUT,DTOUT
|
|---|
| 32 | ASK S ECSPTR=+$G(ECSPTR)
|
|---|
| 33 | I 'ECSPTR G ADREASQ
|
|---|
| 34 | S DIC="^ECR(",DIC(0)="QEALZ",DLAYGO=720.4,DIC("A")="Enter procedure reason: "
|
|---|
| 35 | D ^DIC
|
|---|
| 36 | Q:Y=-1 Q:($D(DUOUT)!$D(DTOUT))
|
|---|
| 37 | I +Y>0 D
|
|---|
| 38 | . S ECPRPTR=+Y
|
|---|
| 39 | . S DIE=DIC,DA=ECPRPTR,DR=".02////1" D ^DIE
|
|---|
| 40 | . K DA,DIC,DLAYGO,DIE,Y
|
|---|
| 41 | . I '$D(^ECL("AC",ECPRPTR,ECSPTR)) D
|
|---|
| 42 | .. S DIC="^ECL(",DIC(0)="L",DLAYGO=720.5,X=ECPRPTR,DIC("DR")=".02////"_ECSPTR
|
|---|
| 43 | .. K DD,DO D FILE^DICN
|
|---|
| 44 | G ASK
|
|---|
| 45 | ADREASQ Q
|
|---|
| 46 | ;
|
|---|
| 47 | ;
|
|---|
| 48 | GETSCRN(ECPPTR) ; Get EC Event Code Screens (#720.3) file internal entry number
|
|---|
| 49 | ; (IEN)
|
|---|
| 50 | ;
|
|---|
| 51 | ; Input: ECPPTR = Event Capture Patient (#721) file IEN
|
|---|
| 52 | ;
|
|---|
| 53 | ; Output: EC Event Code Screens IEN if found or zero if not
|
|---|
| 54 | ;
|
|---|
| 55 | I '$G(ECPPTR) G GETSCRNQ
|
|---|
| 56 | N ECSIEN,ECNODE0
|
|---|
| 57 | S ECSIEN=0,ECNODE0=""
|
|---|
| 58 | ;
|
|---|
| 59 | ;- Get EC Patient record zero node
|
|---|
| 60 | S ECNODE0=$G(^ECH(+ECPPTR,0))
|
|---|
| 61 | I ECNODE0="" G GETSCRNQ
|
|---|
| 62 | ;
|
|---|
| 63 | ;- Get EC Screen IEN from file #720.3 "AP" xref using Loc, DSS Unit,
|
|---|
| 64 | ; Category, and Procedure from EC Patient record
|
|---|
| 65 | S ECSIEN=+$O(^ECJ("AP",+$P(ECNODE0,U,4),+$P(ECNODE0,U,7),+$P(ECNODE0,U,8),$P(ECNODE0,U,9),0))
|
|---|
| 66 | I 'ECSIEN G GETSCRNQ
|
|---|
| 67 | ;
|
|---|
| 68 | ;- If 'Ask Procedure Reasons?' field = Yes and one or more procedure
|
|---|
| 69 | ; reasons entered for the event code screen
|
|---|
| 70 | S ECSIEN=$S((+$P($G(^ECJ(ECSIEN,"PRO")),U,5))&(+$O(^ECL("AD",ECSIEN,0))):ECSIEN,1:0)
|
|---|
| 71 | GETSCRNQ Q +$G(ECSIEN)
|
|---|
| 72 | ;
|
|---|
| 73 | ;
|
|---|
| 74 | GETPRO() ;Get procedure from user and determine type
|
|---|
| 75 | ; Input: None
|
|---|
| 76 | ; Output: 1^type of procedure: X = procedure number
|
|---|
| 77 | ; N = CPT or national number
|
|---|
| 78 | ; A = name of procedure
|
|---|
| 79 | ; S = procedure synonym
|
|---|
| 80 | ; or -1 if unsuccessful
|
|---|
| 81 | ;
|
|---|
| 82 | ; ECPROCED = value of Y from DIR call
|
|---|
| 83 | ; ECMODS = value of CPT modifiers separated by comman
|
|---|
| 84 | ;
|
|---|
| 85 | N ECANS,Y
|
|---|
| 86 | K ECMODS S ECMODS="",ECANS=-1
|
|---|
| 87 | S DIR(0)="FAO",DIR("A")="Enter Procedure: "
|
|---|
| 88 | D ^DIR
|
|---|
| 89 | I $D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(Y="") G GETPROQ
|
|---|
| 90 | I $G(Y)]"" D
|
|---|
| 91 | . 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")
|
|---|
| 92 | . ;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")
|
|---|
| 93 | . I ECANS'="ERR" D
|
|---|
| 94 | .. I "X^N^"[ECANS S ECMODS=$P(Y,"-",2),Y=$P(Y,"-")
|
|---|
| 95 | .. S ECMODS=$TR(ECMODS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 96 | .. S ECANS=1_"^"_ECANS
|
|---|
| 97 | .. S ECPROCED=Y I $E(ECPROCED,1)="&" S ECPROCED=$E(ECPROCED,2,$L(ECPROCED))
|
|---|
| 98 | . I ECANS="ERR" S ECANS=-1
|
|---|
| 99 | ;
|
|---|
| 100 | GETPROQ K DIR,DIRUT,DTOUT,DUOUT
|
|---|
| 101 | Q $G(ECANS)
|
|---|
| 102 | ;
|
|---|
| 103 | ;
|
|---|
| 104 | SRCHTM(ANS) ; Lookup for procedures in ^TMP("ECPRO",$J)
|
|---|
| 105 | ; Input: Procedure type (see first output in GETPRO function above)
|
|---|
| 106 | ; Output: ECPCNT: -1 = no (or bad) procedure type
|
|---|
| 107 | ; 0 = procedure is in local ECPNAME array
|
|---|
| 108 | ; (for A and S types)
|
|---|
| 109 | ; number = procedure number (for X and N types)
|
|---|
| 110 | ;
|
|---|
| 111 | ; ECPNAME = procedure number^procedure name
|
|---|
| 112 | ; (for A and S types)
|
|---|
| 113 | ;
|
|---|
| 114 | N ECNOGO,ECPNAM,ECPUNAM,I,J
|
|---|
| 115 | S ECPCNT=-1,ECPNAM="",J=0
|
|---|
| 116 | I +ANS=-1!($G(ANS)="") G SRCHTMQ
|
|---|
| 117 | I +ANS=1,('$D(ECPROCED)) S ANS=-1 G SRCHTMQ
|
|---|
| 118 | ;
|
|---|
| 119 | ;-- Get 2nd piece of procedure type (letter) for lookup
|
|---|
| 120 | S ANS=$P(ANS,"^",2)
|
|---|
| 121 | ;
|
|---|
| 122 | ;-- Convert to upper case to handle case sensitivity
|
|---|
| 123 | S ECPROCED=$$UPPER^VALM1(ECPROCED)
|
|---|
| 124 | ;
|
|---|
| 125 | ;-- X = procedure number
|
|---|
| 126 | I ANS="X",$D(^TMP("ECPRO",$J,ECPROCED)) S ECPCNT=ECPROCED G SRCHTMQ
|
|---|
| 127 | ;
|
|---|
| 128 | ;-- N = CPT or national number
|
|---|
| 129 | I ANS="N",(+$O(^TMP("ECPRO",$J,"N",ECPROCED,0))>0) S ECPCNT=+$O(^TMP("ECPRO",$J,"N",ECPROCED,0)) G SRCHTMQ
|
|---|
| 130 | ;
|
|---|
| 131 | ;-- If "N" and not in National # xref, chk to see if it's a proc name
|
|---|
| 132 | I ANS="N",(+$O(^TMP("ECPRO",$J,"N",ECPROCED,0))=0) S ANS="A"
|
|---|
| 133 | ;
|
|---|
| 134 | ;-- L = last procedure (spacebar/return functionality)
|
|---|
| 135 | I ANS="L",$D(^TMP("ECLKUP",$J,"LAST")) S ECPCNT=+$P($G(^TMP("ECLKUP",$J,"LAST")),"^") G SRCHTMQ
|
|---|
| 136 | ;
|
|---|
| 137 | ;-- A = name of procedure / S = procedure synonym
|
|---|
| 138 | I ANS="A"!(ANS="S") D
|
|---|
| 139 | . F S ECPNAM=$O(^TMP("ECPRO",$J,$S(ANS="A":"B",ANS="S":"SYN"),ECPNAM)) Q:ECPNAM="" D
|
|---|
| 140 | .. S ECNOGO=0
|
|---|
| 141 | .. S ECPUNAM=$$UPPER^VALM1(ECPNAM)
|
|---|
| 142 | .. F I=1:1:$L(ECPROCED) S:$E(ECPROCED,I)'=$E(ECPUNAM,I) ECNOGO=1
|
|---|
| 143 | .. I 'ECNOGO S J=J+1,ECPCNT=0,ECPNAME(J)=+$O(^TMP("ECPRO",$J,$S(ANS="A":"B",ANS="S":"SYN"),ECPNAM,0))_"^"_ECPNAM
|
|---|
| 144 | I ANS="L",'$D(^TMP("ECLKUP",$J,"LAST")) S ECPCNT=-2
|
|---|
| 145 | SRCHTMQ Q
|
|---|
| 146 | ;
|
|---|
| 147 | ;
|
|---|
| 148 | PRLST() ;Print list if more than one procedure matches
|
|---|
| 149 | ;
|
|---|
| 150 | N ECFL,ECRESP,ECMAX,I
|
|---|
| 151 | S (ECFL,ECRESP,ECMAX,I)=0
|
|---|
| 152 | G:'$D(ECPNAME) PRLSTQ
|
|---|
| 153 | F S I=$O(ECPNAME(I)) Q:'I!(ECFL) D
|
|---|
| 154 | . I '$D(ECPNAME(2)) S (ECFL,ECRESP)=1 Q
|
|---|
| 155 | . W !?5,I,?10,$P(ECPNAME(I),"^",2) S ECMAX=I
|
|---|
| 156 | G:ECFL PRLSTQ
|
|---|
| 157 | CHOOSE S ECRESP=0
|
|---|
| 158 | W !!,"CHOOSE 1-"_ECMAX_": " R ECRESP:DTIME I '$T!(ECRESP["^") G PRLSTQ
|
|---|
| 159 | I +ECRESP<1!(+ECRESP>ECMAX) W *7,"??" G CHOOSE
|
|---|
| 160 | PRLSTQ Q $S(ECRESP>0:+$P(ECPNAME(ECRESP),"^"),1:-1)
|
|---|
| 161 | ;
|
|---|
| 162 | ;
|
|---|
| 163 | ;
|
|---|
| 164 | ERRMSG ;Invalid procedure error message
|
|---|
| 165 | ;
|
|---|
| 166 | W !!,"Enter a valid procedure or press ""^"" to exit.",!
|
|---|
| 167 | Q
|
|---|
| 168 | ;
|
|---|
| 169 | ;
|
|---|
| 170 | ERRMSG2 ;Spacebar/return error message
|
|---|
| 171 | ;
|
|---|
| 172 | W !!?5,"One procedure must be entered before using spacebar/return",!?5,"to get the same procedure.",!
|
|---|
| 173 | Q
|
|---|
| 174 | ;
|
|---|
| 175 | ;
|
|---|
| 176 | KILLV ;
|
|---|
| 177 | K ECPCNT,ECPNAME,ECPROCED,ECPROS,ECX
|
|---|
| 178 | Q
|
|---|
