| 1 | IBDFDE21 ;ALB/AAS - AICS Data Entry, process selection lists ; 11/22/99 4:35pm
|
|---|
| 2 | ;;3.0;AUTOMATED INFO COLLECTION SYS;**4,38,23**;APR 24, 1997
|
|---|
| 3 | ;
|
|---|
| 4 | % G ^IBDFDE
|
|---|
| 5 | ;
|
|---|
| 6 | SEL(SEL) ; -- Build results array
|
|---|
| 7 | N IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR
|
|---|
| 8 | S IBQUIT=0
|
|---|
| 9 | ;
|
|---|
| 10 | S IBDQL=$$QLFR(.RULE,.QLFR)
|
|---|
| 11 | Q:IBQUIT!(IBDQL="^")
|
|---|
| 12 | S IBDQLFR=$P(IBDQL,"^",1) D SEL1
|
|---|
| 13 | ;
|
|---|
| 14 | F QCNT=2:1 S IBDQLFR=$P(IBDQL,"^",QCNT) Q:IBDQLFR="" D SEL1
|
|---|
| 15 | Q
|
|---|
| 16 | ;
|
|---|
| 17 | SEL1 ; -- build selections
|
|---|
| 18 | S IBDX=$G(RESULT(0))+1,RESULT(0)=IBDX
|
|---|
| 19 | I +SEL=SEL S CHOICE=$$CHOICE^IBDFDE2(SEL)
|
|---|
| 20 | I +SEL'=SEL S CHOICE=SEL
|
|---|
| 21 | S DISPTXT=$S($P(CHOICE,"^",5)="":$P(CHOICE,"^"),1:$P(CHOICE,"^",5))
|
|---|
| 22 | W:+$G(QCNT)<2 " ",DISPTXT," ",$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),$P($G(^IBE(357.6,IBDF("PI"),0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX^IBDFDE1($P(CHOICE,"^",3)),1:$P(CHOICE,"^",3))," ",$P(CHOICE,"^",8)_" ",$P(CHOICE,"^",4)
|
|---|
| 23 | ;
|
|---|
| 24 | S RESULT(IBDX)=IBDF("PI")_"^"_$P(CHOICE,"^",3)_"^"_DISPTXT_"^"_$P(CHOICE,"^",8)_"^"_$P(CHOICE,"^",6)_"^"_IBDQLFR_"^"_$G(IBDF("IEN"))_"^^"_$P(CHOICE,"^",9)_"^"_$P(CHOICE,"^",2)_"^^"_$P(CHOICE,"^",12)
|
|---|
| 25 | S IBDPI(IBDF("PI"),IBDX)=RESULT(IBDX)
|
|---|
| 26 | ;
|
|---|
| 27 | ; --validate code for active problem list
|
|---|
| 28 | I $P($G(^IBE(357.6,IBDF("PI"),0)),"^")="PX INPUT PATIENT ACTIVE PROBLEM" D
|
|---|
| 29 | .N X S X=$P(CHOICE,"^",2) Q:X=""
|
|---|
| 30 | .I X=799.9 W !,$C(7),IOINHI,"Warning: The ICD9 Diagnosis associated with this problem needs to be updated!",IOINORM Q
|
|---|
| 31 | .D TESTICD^IBDFN7
|
|---|
| 32 | .I '$D(X) W !,$C(7),IOINHI,"Warning: The ICD9 code associated with this problem is inactive.",IOINORM
|
|---|
| 33 | .;I $D(X) W !,"This is a valid icd9 code"
|
|---|
| 34 | ;
|
|---|
| 35 | ; -- send second and third codes if applicable
|
|---|
| 36 | Q:"PRIMARYSECONDARYADD TO PROBLEM LIST"'[IBDQLFR
|
|---|
| 37 | N IBDQUAL
|
|---|
| 38 | S IBDQUAL=$S(IBDQLFR="PRIMARY":"SECONDARY",1:IBDQLFR)
|
|---|
| 39 | N I,IBDXCD,DISPTXT F I=10,11 I $P(CHOICE,"^",I)]"" D
|
|---|
| 40 | .S IBDX=$G(RESULT(0))+1,RESULT(0)=IBDX
|
|---|
| 41 | .S IBDXCD=$P(CHOICE,"^",I)
|
|---|
| 42 | .N X,Y S X=IBDXCD
|
|---|
| 43 | .D
|
|---|
| 44 | ..I $G(X)="" K X S Y="" Q
|
|---|
| 45 | ..S:$E(X,$L(X))'=" " X=X_" " ; use ba xref, add space to end for lookup.
|
|---|
| 46 | ..S X=$O(^ICD9("BA",X,0))
|
|---|
| 47 | ..I 'X S Y=""
|
|---|
| 48 | ..E S Y=$P(^ICD9(X,0),"^",3)
|
|---|
| 49 | .S DISPTXT=Y
|
|---|
| 50 | .S RESULT(IBDX)=IBDF("PI")_"^"_IBDXCD_"^"_DISPTXT_"^"_$P(CHOICE,"^",8)_"^"_$P(CHOICE,"^",6)_"^"_IBDQUAL_"^"_$G(IBDF("IEN"))_"^^"_$P(CHOICE,"^",9)
|
|---|
| 51 | .S IBDPI(IBDF("PI"),IBDX)=RESULT(IBDX)
|
|---|
| 52 | ;
|
|---|
| 53 | ; -- if ans contains - go to modifier routine
|
|---|
| 54 | I IBDASK="CPT Procedure Code" D MOD^IBDFDE23
|
|---|
| 55 | I IBDASK="Visit Type (EM) Code" D MOD^IBDFDE23
|
|---|
| 56 | Q
|
|---|
| 57 | ;
|
|---|
| 58 | QLFR(RULE,QLFR) ; -- ask Qualifier from array, impose rules
|
|---|
| 59 | N I,X,IBDQ,IBDQ1,QCNT,CNT,ANS,IBDI,OVER,X1,X2,NUM
|
|---|
| 60 | S IBDQ="",CNT=0
|
|---|
| 61 | ;
|
|---|
| 62 | ; -- if only 1 qualifier use it
|
|---|
| 63 | I RULE=1 S IBDQ=$G(QLFR(+$O(QLFR(0)))) W " ",IBDQ G QLFRQ
|
|---|
| 64 | ;
|
|---|
| 65 | S IBDI=0
|
|---|
| 66 | F S IBDI=$O(QLFR(IBDI)) Q:'IBDI S X=$G(QLFR(IBDI)) I X'="" D
|
|---|
| 67 | .S CNT=CNT+1,X(CNT)=X,X2(X)=X
|
|---|
| 68 | .I '$D(X1($E(X),1)) S X1($E(X),1)=X Q
|
|---|
| 69 | .S NUM=$O(X1($E(X),""),-1) S X1($E(X),NUM+1)=X
|
|---|
| 70 | I CNT=1 S IBDQ=$G(X(CNT)) W " ",IBDQ G QLFRQ
|
|---|
| 71 | ;
|
|---|
| 72 | I $D(IBNAQLFR) S ANS=1 S IBDQ=X(ANS) W !,IOINHI,"Using Default Qualifier: "_X(ANS),IOINORM,! Q IBDQ
|
|---|
| 73 | OVER1 ;
|
|---|
| 74 | I CNT<1 G QLFRQ
|
|---|
| 75 | W !,IOINHI," Select a Qualifier",IOINORM
|
|---|
| 76 | I CNT>1 F I=1:1:CNT I X(I)'="" W !?6,I,?10,X(I)
|
|---|
| 77 | W !," Choose 1-",CNT,": " R ANS:DTIME
|
|---|
| 78 | I '$T!($E(ANS,1)="^") S IBDQ="",IBQUIT=1 G QLFRQ
|
|---|
| 79 | I ANS="" G OVER1
|
|---|
| 80 | S OVER=0
|
|---|
| 81 | I $E(ANS,1)="?" D HELP G OVER1
|
|---|
| 82 | I ANS=+ANS D G:OVER OVER1
|
|---|
| 83 | .I ANS<1!(ANS>CNT) S OVER=1 Q
|
|---|
| 84 | .I $G(X(ANS))="" S OVER=1 Q
|
|---|
| 85 | .S IBDQ=X(ANS) W " ",X(ANS)
|
|---|
| 86 | .W !
|
|---|
| 87 | I ANS'=+ANS D G:OVER OVER1
|
|---|
| 88 | .S ANS1=ANS,QCNT=0,IBDQ1=""
|
|---|
| 89 | .F IBD=1:1 S ANS=$P(ANS1,",",IBD) Q:ANS=""!OVER D ONEQLFR I 'OVER,IBDQ'="" S QCNT=QCNT+1,$P(IBDQ1,"^",QCNT)=IBDQ
|
|---|
| 90 | .S IBDQ=IBDQ1
|
|---|
| 91 | .K QCNT,IBDQ1
|
|---|
| 92 | ;
|
|---|
| 93 | QLFRQ Q IBDQ
|
|---|
| 94 | ;
|
|---|
| 95 | ONEQLFR ; -- parse qualifiers
|
|---|
| 96 | S ANS=$$UP^XLFSTR(ANS)
|
|---|
| 97 | I +ANS=ANS D Q
|
|---|
| 98 | .I $G(X(ANS))="" W !,"'"_ANS_"' IS NOT A VALID SELECTION, RE-ENTER" S OVER=1 Q
|
|---|
| 99 | .S IBDQ=X(ANS) W " ",X(ANS)
|
|---|
| 100 | ;
|
|---|
| 101 | I $L(ANS)=1,$G(X1(ANS,1))'="",$O(X1(ANS,1))="" S IBDQ=X1(ANS,1) W:ANS=ANS1 $E(X1(ANS,1),2,99) W:ANS'=ANS1 " ",X1(ANS,1) Q
|
|---|
| 102 | I $G(X2(ANS))'="" S IBDQ=X2(ANS) W " ",X2(ANS) Q
|
|---|
| 103 | I $L(ANS)=1,$G(X1(ANS,1))'="",$O(X1(ANS,1)) S OVER=1 W " Ambiguous answer, enter the number." Q ;S IBDQ=$$PARTLST("X1",ANS,ANS) W $E(X1(ANS,1),2,99) Q
|
|---|
| 104 | S OVER=1
|
|---|
| 105 | Q
|
|---|
| 106 | ;
|
|---|
| 107 | LST ; -- List previous selections and selections to choose from.
|
|---|
| 108 | N I,CNT,IBQUIT,NUM
|
|---|
| 109 | ;
|
|---|
| 110 | ; -- list previous selections
|
|---|
| 111 | D PREVSEL
|
|---|
| 112 | ;
|
|---|
| 113 | ; -- list available choices
|
|---|
| 114 | S (IBQUIT,CNT)=0
|
|---|
| 115 | S NUM=+$$CHOICE^IBDFDE2(0)
|
|---|
| 116 | W !!,"Choose from: "
|
|---|
| 117 | S I=0 F S I=$O(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I)) Q:'I!(IBQUIT) D
|
|---|
| 118 | .S CHOICE=$$CHOICE^IBDFDE2(I)
|
|---|
| 119 | .I '$P(CHOICE,"^",7) W !?16,IOINHI,$P(CHOICE,"^"),IOINORM Q
|
|---|
| 120 | .S CNT=CNT+1,NUMBER(CNT)=I
|
|---|
| 121 | .W !?3,CNT,?7,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^",3)),?16,$P(CHOICE,"^",1)
|
|---|
| 122 | .I NUM>15,NUM>I,'(CNT#15) D PAUSE^IBDFDE I 'IBQUIT W $C(13),$J("",55),$C(13)
|
|---|
| 123 | .;I NUM>15,CNT'=NUM,'(CNT#15) D READ I $G(LISTSEL)<1!($G(LISTSEL)>CNT) K LISTSEL
|
|---|
| 124 | .;I $G(LISTSEL) S SEL=NUMBER(LISTSEL)
|
|---|
| 125 | Q
|
|---|
| 126 | ;
|
|---|
| 127 | PREVSEL ; -- List previous selections
|
|---|
| 128 | N I,CNT
|
|---|
| 129 | S CNT=0
|
|---|
| 130 | ;
|
|---|
| 131 | ; -- list previous selections
|
|---|
| 132 | I $D(IBDPI(IBDF("PI")))>1 S I=0 F S I=$O(IBDPI(IBDF("PI"),I)) Q:'I D
|
|---|
| 133 | .Q:$P(IBDPI(IBDF("PI"),I),"^",7)'=IBDF("IEN") ; not the same list
|
|---|
| 134 | .S CNT=CNT+1
|
|---|
| 135 | .W:CNT=1 !!,IOINHI," You have previously selected: ",IOINORM
|
|---|
| 136 | .W !,?7,$S($P($G(^IBE(357.6,+IBDPI(IBDF("PI"),I),0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX^IBDFDE1($P(IBDPI(IBDF("PI"),I),"^",2)),1:$P(IBDPI(IBDF("PI"),I),"^",2))
|
|---|
| 137 | .W ?16,$P(IBDPI(IBDF("PI"),I),"^",3),?50,$P(IBDPI(IBDF("PI"),I),"^",6)
|
|---|
| 138 | W !
|
|---|
| 139 | Q
|
|---|
| 140 | ;
|
|---|
| 141 | DEFAULT ; -- compute default answer
|
|---|
| 142 | N CNT,SEL,NAME,PIECE,SELAST
|
|---|
| 143 | S (CNT,SEL,SELAST)=0
|
|---|
| 144 | S NAME=$P($G(^IBE(357.6,+IBDF("PI"),0)),"^")
|
|---|
| 145 | S PIECE=$S(NAME["INPUT PROCEDURE CODE":2,NAME["INPUT DIAGNOSIS CODE":2,NAME["INPUT VISIT TYPE":2,1:3)
|
|---|
| 146 | F S SEL=$O(IBDPI(IBDF("PI"),SEL)) Q:'SEL D
|
|---|
| 147 | .Q:$P(IBDPI(IBDF("PI"),SEL),"^",7)'=IBDF("IEN") ; not the same list
|
|---|
| 148 | .S CNT=CNT+1,SELAST=SEL
|
|---|
| 149 | I $G(SELAST) S DIR("B")=$P(IBDPI(IBDF("PI"),SELAST),"^",PIECE),IBDEFLT(IBDF("PI"))=DIR("B")
|
|---|
| 150 | D PREVSEL
|
|---|
| 151 | Q
|
|---|
| 152 | ;
|
|---|
| 153 | DEFPROV ; -- find default provider, not on form
|
|---|
| 154 | N SEL,IBDX
|
|---|
| 155 | S IBDF("PI")=$O(^IBE(357.6,"B","INPUT PROVIDER",0))
|
|---|
| 156 | Q:$D(IBDPI(IBDF("PI")))
|
|---|
| 157 | S SEL=$G(IBDF("PROVIDER")) I 'SEL S SEL=$$PRDEF^IBDFRPC3(IBDF("CLINIC"))
|
|---|
| 158 | Q:'SEL
|
|---|
| 159 | S $P(IBDF("PROVIDER PI"),"^",2)=1 ;flag not on form
|
|---|
| 160 | S IBDX=$G(IBDSEL(0))+1,IBDSEL(0)=IBDX
|
|---|
| 161 | S IBDSEL(IBDX)=IBDF("PI")_"^"_SEL_"^"_$P($G(^VA(200,+SEL,0)),"^")_"^^^PRIMARY^"
|
|---|
| 162 | S IBDPI(IBDF("PI"),IBDX)=IBDSEL(IBDX)
|
|---|
| 163 | W:'$G(IBDF("PROVIDER")) !!,"No Provider Block on form. Using Default Provider from Clinic as Primary.",!
|
|---|
| 164 | W:$G(IBDF("PROVIDER")) !!,"Using Provider: "
|
|---|
| 165 | W " ",$P(^VA(200,+SEL,0),"^")," PRIMARY",!
|
|---|
| 166 | Q
|
|---|
| 167 | ;
|
|---|
| 168 | HELP ; --
|
|---|
| 169 | W !,"You must choose a data qualifier for this item. Enter a number from 1-",CNT,!,"Or enter the first letter, or enter the full name. Enter more than one",!,"qualifier separated by commas (ie 1,2 or P,A).",!
|
|---|
| 170 | Q
|
|---|
| 171 | ;
|
|---|
| 172 | OTHER(IBDX) ; -- allow input of an additional item
|
|---|
| 173 | N I,J,X,Y,DIR,DIRUT,DUOUT,SEL,SELX,NARR,DIC,DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX,IBDFILE
|
|---|
| 174 | ;
|
|---|
| 175 | ; -- strip the cpt code if modifiers are added cpt-mod,mod,mod...
|
|---|
| 176 | ;
|
|---|
| 177 | I IBDX["-" S IBDX=$P(IBDX,"-")
|
|---|
| 178 | I $G(IBDF("LEXICON")) D Q:'$D(IBDLEX)
|
|---|
| 179 | .I $D(^LEX)>1 S X="LEXSET" X ^%ZOSF("TEST") I $T D CONFIG^LEXSET("ICD","ICD") S IBDLEX=1
|
|---|
| 180 | .I '$D(IBDLEX) S X="GMPTSET" X ^%ZOSF("TEST") I $T D CONFIG^GMPTSET("GMPL","PL1") S IBDLEX=1
|
|---|
| 181 | .;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)
|
|---|
| 182 | S SELX=-1
|
|---|
| 183 | I '$G(IBDF("OTHER")) G OTHQ
|
|---|
| 184 | I $L($G(IBDX)) S X=IBDX S DIC(0)="EQMZ"
|
|---|
| 185 | S DIC("A")="Select Other "_$G(IBDASK)
|
|---|
| 186 | S DIC=$P(IBDF("OTHER"),"^") I $P(IBDF("OTHER"),"^",2)'="" S DIC("S")=$P(IBDF("OTHER"),"^",2,99)
|
|---|
| 187 | D ^DIC G OTHQ:+Y<1
|
|---|
| 188 | K DIC
|
|---|
| 189 | S SEL=Y
|
|---|
| 190 | W !!,$C(7),"WARNING: Item selected not from Encounter Form."
|
|---|
| 191 | ;
|
|---|
| 192 | I IBDF("PI")=$G(IBDF("PROVIDER PI")) W ! S SELX=$P($G(^VA(200,+Y,0)),"^",1)_"^^"_+Y_"^^^^1" G OTHQ
|
|---|
| 193 | ;
|
|---|
| 194 | W "...Entry of Narrative Required!",!
|
|---|
| 195 | S IBDFILE=+IBDF("OTHER")
|
|---|
| 196 | S:IBDFILE=81 DIR("B")=$P(Y(0),"^",2)
|
|---|
| 197 | ;S:IBDFILE=80 DIR("B")=$P(Y(0),"^",3)
|
|---|
| 198 | S:IBDFILE=80 DIR("B")=$S($L($G(^ICD9(+Y,1)))<81:^ICD9(+Y,1),1:$P(Y(0),"^",3))
|
|---|
| 199 | S:IBDFILE=357.69 DIR("B")=$P(Y(0),"^",3)
|
|---|
| 200 | I IBDFILE>9999999,IBDFILE<10000000 S DIR("B")=$P(Y(0),"^",1)
|
|---|
| 201 | S DIR(0)="FO^3:80",DIR("A")="Narrative" D ^DIR K DIR G:$G(DIRUT) OTHQ
|
|---|
| 202 | S NARR=Y
|
|---|
| 203 | ;
|
|---|
| 204 | S SELX=$S((IBDFILE<9999999)&(IBDFILE'=757.01):NARR_"^^"_$P(SEL,"^",2)_"^^^^1",1:NARR_"^^"_$P(SEL,"^",1)_"^^^^1")
|
|---|
| 205 | OTHQ Q $S(SELX=-1:"",1:SELX)
|
|---|
| 206 | ;
|
|---|
| 207 | PARTLST(ARY,NEXT,ANS) ; -- input has more than one match, prompt for which one
|
|---|
| 208 | N I,J,K,N,IBD,ANS2,SEL,CHOICE
|
|---|
| 209 | S SEL=0
|
|---|
| 210 | S NEXT=$E(NEXT,1,$L(NEXT)-1)_$C($A($E(NEXT,$L(NEXT)))-1)_"~"
|
|---|
| 211 | ;
|
|---|
| 212 | S J=0,K=NEXT F S K=$O(@ARY@(K)) Q:$E(K,1,$L(ANS))'=ANS D
|
|---|
| 213 | .S N=0 F S N=$O(@ARY@(K,N)) Q:'N D
|
|---|
| 214 | ..S J=J+1,IBD(J)=@ARY@(K,N),CHOICE=$$CHOICE^IBDFDE2(IBD(J))
|
|---|
| 215 | ..W !?6,J,?10,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^",3)),?20,$P(CHOICE,"^",1),?50," ",$P(CHOICE,"^",8)," ",$P(CHOICE,"^",4)
|
|---|
| 216 | ;
|
|---|
| 217 | ASKNUM I J<1 G PARTLQ
|
|---|
| 218 | W !," Choose 1-",J,": " R ANS2:DTIME
|
|---|
| 219 | I '$T!($E(ANS2,1)="^")!(ANS2="") S SEL="" G PARTLQ
|
|---|
| 220 | I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",J G ASKNUM
|
|---|
| 221 | S ANS2=+ANS2
|
|---|
| 222 | I ANS2<1!(ANS2>J) G ASKNUM
|
|---|
| 223 | I $G(IBD(ANS2))="" G ASKNUM
|
|---|
| 224 | W !
|
|---|
| 225 | S SEL=$G(IBD(ANS2))
|
|---|
| 226 | PARTLQ Q SEL
|
|---|
| 227 | ;
|
|---|
| 228 | READ ; -- get input from list
|
|---|
| 229 | N ANS2
|
|---|
| 230 | G:CNT<1 READQ
|
|---|
| 231 | W !," Choose 1-",CNT,": " R ANS2:DTIME
|
|---|
| 232 | I '$T!($E(ANS2,1)="^") S IBQUIT=1 G READQ
|
|---|
| 233 | I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",CNT," or return to see more." G READ
|
|---|
| 234 | S ANS2=+ANS2
|
|---|
| 235 | I ANS2<1!(ANS2>CNT) W $C(7),! G READ
|
|---|
| 236 | I $G(NUMBER(CNT))="" G READ
|
|---|
| 237 | W !
|
|---|
| 238 | READQ Q
|
|---|
