- IBDFDE21 ;ALB/AAS - AICS Data Entry, process selection lists ; 11/22/99 4:35pm
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**4,38,23,63**;APR 24, 1997;Build 80
- ;
- ;
- % G ^IBDFDE
- ;
- SEL(SEL) ; -- Build results array
- N IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR
- S IBQUIT=0
- ;
- S IBDQL=$$QLFR(.RULE,.QLFR)
- Q:IBQUIT!(IBDQL="^")
- S IBDQLFR=$P(IBDQL,"^",1) D SEL1
- ;
- F QCNT=2:1 S IBDQLFR=$P(IBDQL,"^",QCNT) Q:IBDQLFR="" D SEL1
- Q
- ;
- SEL1 ; -- build selections
- N IBDIMP,IBDIBX
- S IBDIMP=$$IMPDATE^IBDUTICD(30)
- S IBDIBX=799.9
- I DT'<IBDIMP S IBDIBX="R69."
- S IBDX=$G(RESULT(0))+1,RESULT(0)=IBDX
- I +SEL=SEL S CHOICE=$$CHOICE^IBDFDE2(SEL)
- I +SEL'=SEL S CHOICE=SEL
- S DISPTXT=$S($P(CHOICE,"^",5)="":$P(CHOICE,"^"),1:$P(CHOICE,"^",5))
- 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)
- ;
- 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)
- S IBDPI(IBDF("PI"),IBDX)=RESULT(IBDX)
- ;
- ; --validate code for active problem list
- I $P($G(^IBE(357.6,IBDF("PI"),0)),"^")="PX INPUT PATIENT ACTIVE PROBLEM" D
- .N X S X=$P(CHOICE,"^",2) Q:X=""
- .I X=IBDIBX W !,$C(7),IOINHI,"Warning: The ICD",$S(DT'<IBDIMP:"10",1:"9")," Diagnosis associated with this problem needs to be updated!",IOINORM Q
- .D TESTICD^IBDFN7
- .I '$D(X) W !,$C(7),IOINHI,"Warning: The ICD",$S(DT'<IBDIMP:"10",1:"9")," code associated with this problem is inactive.",IOINORM
- .;I $D(X) W !,"This is a valid icd9 code"
- ;
- ; -- send second and third codes if applicable
- Q:"PRIMARYSECONDARYADD TO PROBLEM LIST"'[IBDQLFR
- N IBDQUAL
- S IBDQUAL=$S(IBDQLFR="PRIMARY":"SECONDARY",1:IBDQLFR)
- N I,IBDXCD,DISPTXT F I=10,11 I $P(CHOICE,"^",I)]"" D
- .S IBDX=$G(RESULT(0))+1,RESULT(0)=IBDX
- .S IBDXCD=$P(CHOICE,"^",I)
- .N X,Y S X=IBDXCD
- .D
- ..I $G(X)="" K X S Y="" Q
- ..;S:$E(X,$L(X))'=" " X=X_" " ; use ba xref, add space to end for lookup.
- ..;S X=$O(^ICD9("BA",X,0))
- ..;I 'X S Y=""
- ..;E S Y=$P(^ICD9(X,0),"^",3)
- ..;S X=$$ICDDX^ICDCODE(X)
- ..;get by external code using "DIAG"
- ..S X=$$ICDDATA^ICDXCODE("DIAG",X,DT)
- ..I +X<1 K X S Y="" Q
- ..E S Y=$P(X,U,4)
- .S DISPTXT=Y
- .S RESULT(IBDX)=IBDF("PI")_"^"_IBDXCD_"^"_DISPTXT_"^"_$P(CHOICE,"^",8)_"^"_$P(CHOICE,"^",6)_"^"_IBDQUAL_"^"_$G(IBDF("IEN"))_"^^"_$P(CHOICE,"^",9)
- .S IBDPI(IBDF("PI"),IBDX)=RESULT(IBDX)
- ;
- ; -- if ans contains - go to modifier routine
- I IBDASK="CPT Procedure Code" D MOD^IBDFDE23
- I IBDASK="Visit Type (EM) Code" D MOD^IBDFDE23
- Q
- ;
- QLFR(RULE,QLFR) ; -- ask Qualifier from array, impose rules
- N I,X,IBDQ,IBDQ1,QCNT,CNT,ANS,IBDI,OVER,X1,X2,NUM
- S IBDQ="",CNT=0
- ;
- ; -- if only 1 qualifier use it
- I RULE=1 S IBDQ=$G(QLFR(+$O(QLFR(0)))) W " ",IBDQ G QLFRQ
- ;
- S IBDI=0
- F S IBDI=$O(QLFR(IBDI)) Q:'IBDI S X=$G(QLFR(IBDI)) I X'="" D
- .S CNT=CNT+1,X(CNT)=X,X2(X)=X
- .I '$D(X1($E(X),1)) S X1($E(X),1)=X Q
- .S NUM=$O(X1($E(X),""),-1) S X1($E(X),NUM+1)=X
- I CNT=1 S IBDQ=$G(X(CNT)) W " ",IBDQ G QLFRQ
- ;
- I $D(IBNAQLFR) S ANS=1 S IBDQ=X(ANS) W !,IOINHI,"Using Default Qualifier: "_X(ANS),IOINORM,! Q IBDQ
- OVER1 ;
- I CNT<1 G QLFRQ
- W !,IOINHI," Select a Qualifier",IOINORM
- I CNT>1 F I=1:1:CNT I X(I)'="" W !?6,I,?10,X(I)
- W !," Choose 1-",CNT,": " R ANS:DTIME
- I '$T!($E(ANS,1)="^") S IBDQ="",IBQUIT=1 G QLFRQ
- I ANS="" G OVER1
- S OVER=0
- I $E(ANS,1)="?" D HELP G OVER1
- I ANS=+ANS D G:OVER OVER1
- .I ANS<1!(ANS>CNT) S OVER=1 Q
- .I $G(X(ANS))="" S OVER=1 Q
- .S IBDQ=X(ANS) W " ",X(ANS)
- .W !
- I ANS'=+ANS D G:OVER OVER1
- .S ANS1=ANS,QCNT=0,IBDQ1=""
- .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
- .S IBDQ=IBDQ1
- .K QCNT,IBDQ1
- ;
- QLFRQ Q IBDQ
- ;
- ONEQLFR ; -- parse qualifiers
- S ANS=$$UP^XLFSTR(ANS)
- I +ANS=ANS D Q
- .I $G(X(ANS))="" W !,"'"_ANS_"' IS NOT A VALID SELECTION, RE-ENTER" S OVER=1 Q
- .S IBDQ=X(ANS) W " ",X(ANS)
- ;
- 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
- I $G(X2(ANS))'="" S IBDQ=X2(ANS) W " ",X2(ANS) Q
- 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
- S OVER=1
- Q
- ;
- LST ; -- List previous selections and selections to choose from.
- N I,CNT,IBQUIT,NUM
- ;
- ; -- list previous selections
- D PREVSEL
- ;
- ; -- list available choices
- S (IBQUIT,CNT)=0
- S NUM=+$$CHOICE^IBDFDE2(0)
- W !!,"Choose from: "
- S I=0 F S I=$O(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I)) Q:'I!(IBQUIT) D
- .S CHOICE=$$CHOICE^IBDFDE2(I)
- .I '$P(CHOICE,"^",7) W !?16,IOINHI,$P(CHOICE,"^"),IOINORM Q
- .S CNT=CNT+1,NUMBER(CNT)=I
- .W !?3,CNT,?7,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^",3)),?16,$P(CHOICE,"^",1)
- .I NUM>15,NUM>I,'(CNT#15) D PAUSE^IBDFDE I 'IBQUIT W $C(13),$J("",55),$C(13)
- .;I NUM>15,CNT'=NUM,'(CNT#15) D READ I $G(LISTSEL)<1!($G(LISTSEL)>CNT) K LISTSEL
- .;I $G(LISTSEL) S SEL=NUMBER(LISTSEL)
- Q
- ;
- PREVSEL ; -- List previous selections
- N I,CNT
- S CNT=0
- ;
- ; -- list previous selections
- I $D(IBDPI(IBDF("PI")))>1 S I=0 F S I=$O(IBDPI(IBDF("PI"),I)) Q:'I D
- .Q:$P(IBDPI(IBDF("PI"),I),"^",7)'=IBDF("IEN") ; not the same list
- .S CNT=CNT+1
- .W:CNT=1 !!,IOINHI," You have previously selected: ",IOINORM
- .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))
- .W ?16,$P(IBDPI(IBDF("PI"),I),"^",3),?50,$P(IBDPI(IBDF("PI"),I),"^",6)
- W !
- Q
- ;
- DEFAULT ; -- compute default answer
- N CNT,SEL,NAME,PIECE,SELAST
- S (CNT,SEL,SELAST)=0
- S NAME=$P($G(^IBE(357.6,+IBDF("PI"),0)),"^")
- S PIECE=$S(NAME["INPUT PROCEDURE CODE":2,NAME["INPUT DIAGNOSIS CODE":2,NAME["INPUT VISIT TYPE":2,1:3)
- F S SEL=$O(IBDPI(IBDF("PI"),SEL)) Q:'SEL D
- .Q:$P(IBDPI(IBDF("PI"),SEL),"^",7)'=IBDF("IEN") ; not the same list
- .S CNT=CNT+1,SELAST=SEL
- I $G(SELAST) S DIR("B")=$P(IBDPI(IBDF("PI"),SELAST),"^",PIECE),IBDEFLT(IBDF("PI"))=DIR("B")
- D PREVSEL
- Q
- ;
- DEFPROV ; -- find default provider, not on form
- N SEL,IBDX
- S IBDF("PI")=$O(^IBE(357.6,"B","INPUT PROVIDER",0))
- Q:$D(IBDPI(IBDF("PI")))
- S SEL=$G(IBDF("PROVIDER")) I 'SEL S SEL=$$PRDEF^IBDFRPC3(IBDF("CLINIC"))
- Q:'SEL
- S $P(IBDF("PROVIDER PI"),"^",2)=1 ;flag not on form
- S IBDX=$G(IBDSEL(0))+1,IBDSEL(0)=IBDX
- S IBDSEL(IBDX)=IBDF("PI")_"^"_SEL_"^"_$P($G(^VA(200,+SEL,0)),"^")_"^^^PRIMARY^"
- S IBDPI(IBDF("PI"),IBDX)=IBDSEL(IBDX)
- W:'$G(IBDF("PROVIDER")) !!,"No Provider Block on form. Using Default Provider from Clinic as Primary.",!
- W:$G(IBDF("PROVIDER")) !!,"Using Provider: "
- W " ",$P(^VA(200,+SEL,0),"^")," PRIMARY",!
- Q
- ;
- HELP ; --
- 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).",!
- Q
- ;
- OTHER(IBDX) ; -- allow input of an additional item
- N I,J,X,Y,DIR,DIRUT,DUOUT,SEL,SELX,NARR,DIC,DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX,IBDFILE,IBDIMP,IBDCSYS,IBDX
- ;
- ; -- strip the cpt code if modifiers are added cpt-mod,mod,mod...
- ;
- I IBDX["-" S IBDX=$P(IBDX,"-")
- I $G(IBDF("LEXICON")) D Q:'$D(IBDLEX)
- .I $D(^LEX)>1 S X="LEXSET" X ^%ZOSF("TEST") I $T D CONFIG^LEXSET("ICD","ICD") S IBDLEX=1
- .I '$D(IBDLEX) S X="GMPTSET" X ^%ZOSF("TEST") I $T D CONFIG^GMPTSET("GMPL","PL1") S IBDLEX=1
- .;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)
- S SELX=-1
- I '$G(IBDF("OTHER")) G OTHQ
- I $L($G(IBDX)) S X=IBDX S DIC(0)="EQMZ"
- S DIC("A")="Select Other "_$G(IBDASK)
- S DIC=$P(IBDF("OTHER"),"^") I $P(IBDF("OTHER"),"^",2)'="" S DIC("S")=$P(IBDF("OTHER"),"^",2,99)
- D ^DIC G OTHQ:+Y<1
- K DIC
- S SEL=Y
- W !!,$C(7),"WARNING: Item selected not from Encounter Form."
- ;
- I IBDF("PI")=$G(IBDF("PROVIDER PI")) W ! S SELX=$P($G(^VA(200,+Y,0)),"^",1)_"^^"_+Y_"^^^^1" G OTHQ
- ;
- W "...Entry of Narrative Required!",!
- S IBDFILE=+IBDF("OTHER")
- S:IBDFILE=81 DIR("B")=$P(Y(0),"^",2)
- S:IBDFILE=80 IBDIMP=$$IMPDATE^IBDUTICD(30),IBDCSYS=$S(DT'<IBDIMP:30,1:1),IBDX=$P($$ICDDATA^ICDXCODE(IBDCSYS,+Y,DT),U,4)
- S:IBDFILE=80 DIR("B")=$S($L(IBDX)<81:IBDX,1:$P(Y(0),"^",3))
- S:IBDFILE=357.69 DIR("B")=$P(Y(0),"^",3)
- I IBDFILE>9999999,IBDFILE<10000000 S DIR("B")=$P(Y(0),"^",1)
- S DIR(0)="FO^3:80",DIR("A")="Narrative" D ^DIR K DIR G:$G(DIRUT) OTHQ
- S NARR=Y
- ;
- S SELX=$S((IBDFILE<9999999)&(IBDFILE'=757.01):NARR_"^^"_$P(SEL,"^",2)_"^^^^1",1:NARR_"^^"_$P(SEL,"^",1)_"^^^^1")
- OTHQ Q $S(SELX=-1:"",1:SELX)
- ;
- PARTLST(ARY,NEXT,ANS) ; -- input has more than one match, prompt for which one
- N I,J,K,N,IBD,ANS2,SEL,CHOICE
- S SEL=0
- S NEXT=$E(NEXT,1,$L(NEXT)-1)_$C($A($E(NEXT,$L(NEXT)))-1)_"~"
- ;
- S J=0,K=NEXT F S K=$O(@ARY@(K)) Q:$E(K,1,$L(ANS))'=ANS D
- .S N=0 F S N=$O(@ARY@(K,N)) Q:'N D
- ..S J=J+1,IBD(J)=@ARY@(K,N),CHOICE=$$CHOICE^IBDFDE2(IBD(J))
- ..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)
- ;
- ASKNUM I J<1 G PARTLQ
- W !," Choose 1-",J,": " R ANS2:DTIME
- I '$T!($E(ANS2,1)="^")!(ANS2="") S SEL="" G PARTLQ
- I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",J G ASKNUM
- S ANS2=+ANS2
- I ANS2<1!(ANS2>J) G ASKNUM
- I $G(IBD(ANS2))="" G ASKNUM
- W !
- S SEL=$G(IBD(ANS2))
- PARTLQ Q SEL
- ;
- READ ; -- get input from list
- N ANS2
- G:CNT<1 READQ
- W !," Choose 1-",CNT,": " R ANS2:DTIME
- I '$T!($E(ANS2,1)="^") S IBQUIT=1 G READQ
- I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",CNT," or return to see more." G READ
- S ANS2=+ANS2
- I ANS2<1!(ANS2>CNT) W $C(7),! G READ
- I $G(NUMBER(CNT))="" G READ
- W !
- READQ Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE21 10043 printed Dec 13, 2024@02:52:16 Page 2
- IBDFDE21 ;ALB/AAS - AICS Data Entry, process selection lists ; 11/22/99 4:35pm
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**4,38,23,63**;APR 24, 1997;Build 80
- +2 ;
- +3 ;
- % GOTO ^IBDFDE
- +1 ;
- SEL(SEL) ; -- Build results array
- +1 NEW IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR
- +2 SET IBQUIT=0
- +3 ;
- +4 SET IBDQL=$$QLFR(.RULE,.QLFR)
- +5 if IBQUIT!(IBDQL="^")
- QUIT
- +6 SET IBDQLFR=$PIECE(IBDQL,"^",1)
- DO SEL1
- +7 ;
- +8 FOR QCNT=2:1
- SET IBDQLFR=$PIECE(IBDQL,"^",QCNT)
- if IBDQLFR=""
- QUIT
- DO SEL1
- +9 QUIT
- +10 ;
- SEL1 ; -- build selections
- +1 NEW IBDIMP,IBDIBX
- +2 SET IBDIMP=$$IMPDATE^IBDUTICD(30)
- +3 SET IBDIBX=799.9
- +4 IF DT'<IBDIMP
- SET IBDIBX="R69."
- +5 SET IBDX=$GET(RESULT(0))+1
- SET RESULT(0)=IBDX
- +6 IF +SEL=SEL
- SET CHOICE=$$CHOICE^IBDFDE2(SEL)
- +7 IF +SEL'=SEL
- SET CHOICE=SEL
- +8 SET DISPTXT=$SELECT($PIECE(CHOICE,"^",5)="":$PIECE(CHOICE,"^"),1:$PIECE(CHOICE,"^",5))
- +9 if +$GET(QCNT)<2
- WRITE " ",DISPTXT," ",$SELECT($PIECE(CHOICE,"^",2)'="":$PIECE(CHOICE,"^",2),$PIECE(...
- ... $GET(^IBE(357.6,IBDF("PI"),0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX^IBDFDE1($PIECE(CHOICE,"^",3)),1:$PIECE(CHOICE,"^",3))," ",$PIECE(CHOICE,"^",8)_" ",$PIECE(CHOICE,"^",4)
- +10 ;
- +11 SET RESULT(IBDX)=IBDF("PI")_"^"_$PIECE(CHOICE,"^",3)_"^"_DISPTXT_"^"_$PIECE(CHOICE,"^",8)_"^"_$PIECE(CHOICE,"^",6)_"^"_IBDQLFR_"^"_$GET(IBDF("IEN"))_"^^"_$PIECE(CHOICE,"^",9)_"^"_$PIECE(CHOICE,"^",2)_"^^"_$PIECE(CHOICE,"^",12)
- +12 SET IBDPI(IBDF("PI"),IBDX)=RESULT(IBDX)
- +13 ;
- +14 ; --validate code for active problem list
- +15 IF $PIECE($GET(^IBE(357.6,IBDF("PI"),0)),"^")="PX INPUT PATIENT ACTIVE PROBLEM"
- Begin DoDot:1
- +16 NEW X
- SET X=$PIECE(CHOICE,"^",2)
- if X=""
- QUIT
- +17 IF X=IBDIBX
- WRITE !,$CHAR(7),IOINHI,"Warning: The ICD",$SELECT(DT'<IBDIMP:"10",1:"9")," Diagnosis associated with this problem needs to be updated!",IOINORM
- QUIT
- +18 DO TESTICD^IBDFN7
- +19 IF '$DATA(X)
- WRITE !,$CHAR(7),IOINHI,"Warning: The ICD",$SELECT(DT'<IBDIMP:"10",1:"9")," code associated with this problem is inactive.",IOINORM
- +20 ;I $D(X) W !,"This is a valid icd9 code"
- End DoDot:1
- +21 ;
- +22 ; -- send second and third codes if applicable
- +23 if "PRIMARYSECONDARYADD TO PROBLEM LIST"'[IBDQLFR
- QUIT
- +24 NEW IBDQUAL
- +25 SET IBDQUAL=$SELECT(IBDQLFR="PRIMARY":"SECONDARY",1:IBDQLFR)
- +26 NEW I,IBDXCD,DISPTXT
- FOR I=10,11
- IF $PIECE(CHOICE,"^",I)]""
- Begin DoDot:1
- +27 SET IBDX=$GET(RESULT(0))+1
- SET RESULT(0)=IBDX
- +28 SET IBDXCD=$PIECE(CHOICE,"^",I)
- +29 NEW X,Y
- SET X=IBDXCD
- +30 Begin DoDot:2
- +31 IF $GET(X)=""
- KILL X
- SET Y=""
- QUIT
- +32 ;S:$E(X,$L(X))'=" " X=X_" " ; use ba xref, add space to end for lookup.
- +33 ;S X=$O(^ICD9("BA",X,0))
- +34 ;I 'X S Y=""
- +35 ;E S Y=$P(^ICD9(X,0),"^",3)
- +36 ;S X=$$ICDDX^ICDCODE(X)
- +37 ;get by external code using "DIAG"
- +38 SET X=$$ICDDATA^ICDXCODE("DIAG",X,DT)
- +39 IF +X<1
- KILL X
- SET Y=""
- QUIT
- +40 IF '$TEST
- SET Y=$PIECE(X,U,4)
- End DoDot:2
- +41 SET DISPTXT=Y
- +42 SET RESULT(IBDX)=IBDF("PI")_"^"_IBDXCD_"^"_DISPTXT_"^"_$PIECE(CHOICE,"^",8)_"^"_$PIECE(CHOICE,"^",6)_"^"_IBDQUAL_"^"_$GET(IBDF("IEN"))_"^^"_$PIECE(CHOICE,"^",9)
- +43 SET IBDPI(IBDF("PI"),IBDX)=RESULT(IBDX)
- End DoDot:1
- +44 ;
- +45 ; -- if ans contains - go to modifier routine
- +46 IF IBDASK="CPT Procedure Code"
- DO MOD^IBDFDE23
- +47 IF IBDASK="Visit Type (EM) Code"
- DO MOD^IBDFDE23
- +48 QUIT
- +49 ;
- QLFR(RULE,QLFR) ; -- ask Qualifier from array, impose rules
- +1 NEW I,X,IBDQ,IBDQ1,QCNT,CNT,ANS,IBDI,OVER,X1,X2,NUM
- +2 SET IBDQ=""
- SET CNT=0
- +3 ;
- +4 ; -- if only 1 qualifier use it
- +5 IF RULE=1
- SET IBDQ=$GET(QLFR(+$ORDER(QLFR(0))))
- WRITE " ",IBDQ
- GOTO QLFRQ
- +6 ;
- +7 SET IBDI=0
- +8 FOR
- SET IBDI=$ORDER(QLFR(IBDI))
- if 'IBDI
- QUIT
- SET X=$GET(QLFR(IBDI))
- IF X'=""
- Begin DoDot:1
- +9 SET CNT=CNT+1
- SET X(CNT)=X
- SET X2(X)=X
- +10 IF '$DATA(X1($EXTRACT(X),1))
- SET X1($EXTRACT(X),1)=X
- QUIT
- +11 SET NUM=$ORDER(X1($EXTRACT(X),""),-1)
- SET X1($EXTRACT(X),NUM+1)=X
- End DoDot:1
- +12 IF CNT=1
- SET IBDQ=$GET(X(CNT))
- WRITE " ",IBDQ
- GOTO QLFRQ
- +13 ;
- +14 IF $DATA(IBNAQLFR)
- SET ANS=1
- SET IBDQ=X(ANS)
- WRITE !,IOINHI,"Using Default Qualifier: "_X(ANS),IOINORM,!
- QUIT IBDQ
- OVER1 ;
- +1 IF CNT<1
- GOTO QLFRQ
- +2 WRITE !,IOINHI," Select a Qualifier",IOINORM
- +3 IF CNT>1
- FOR I=1:1:CNT
- IF X(I)'=""
- WRITE !?6,I,?10,X(I)
- +4 WRITE !," Choose 1-",CNT,": "
- READ ANS:DTIME
- +5 IF '$TEST!($EXTRACT(ANS,1)="^")
- SET IBDQ=""
- SET IBQUIT=1
- GOTO QLFRQ
- +6 IF ANS=""
- GOTO OVER1
- +7 SET OVER=0
- +8 IF $EXTRACT(ANS,1)="?"
- DO HELP
- GOTO OVER1
- +9 IF ANS=+ANS
- Begin DoDot:1
- +10 IF ANS<1!(ANS>CNT)
- SET OVER=1
- QUIT
- +11 IF $GET(X(ANS))=""
- SET OVER=1
- QUIT
- +12 SET IBDQ=X(ANS)
- WRITE " ",X(ANS)
- +13 WRITE !
- End DoDot:1
- if OVER
- GOTO OVER1
- +14 IF ANS'=+ANS
- Begin DoDot:1
- +15 SET ANS1=ANS
- SET QCNT=0
- SET IBDQ1=""
- +16 FOR IBD=1:1
- SET ANS=$PIECE(ANS1,",",IBD)
- if ANS=""!OVER
- QUIT
- DO ONEQLFR
- IF 'OVER
- IF IBDQ'=""
- SET QCNT=QCNT+1
- SET $PIECE(IBDQ1,"^",QCNT)=IBDQ
- +17 SET IBDQ=IBDQ1
- +18 KILL QCNT,IBDQ1
- End DoDot:1
- if OVER
- GOTO OVER1
- +19 ;
- QLFRQ QUIT IBDQ
- +1 ;
- ONEQLFR ; -- parse qualifiers
- +1 SET ANS=$$UP^XLFSTR(ANS)
- +2 IF +ANS=ANS
- Begin DoDot:1
- +3 IF $GET(X(ANS))=""
- WRITE !,"'"_ANS_"' IS NOT A VALID SELECTION, RE-ENTER"
- SET OVER=1
- QUIT
- +4 SET IBDQ=X(ANS)
- WRITE " ",X(ANS)
- End DoDot:1
- QUIT
- +5 ;
- +6 IF $LENGTH(ANS)=1
- IF $GET(X1(ANS,1))'=""
- IF $ORDER(X1(ANS,1))=""
- SET IBDQ=X1(ANS,1)
- if ANS=ANS1
- WRITE $EXTRACT(X1(ANS,1),2,99)
- if ANS'=ANS1
- WRITE " ",X1(ANS,1)
- QUIT
- +7 IF $GET(X2(ANS))'=""
- SET IBDQ=X2(ANS)
- WRITE " ",X2(ANS)
- QUIT
- +8 ;S IBDQ=$$PARTLST("X1",ANS,ANS) W $E(X1(ANS,1),2,99) Q
- IF $LENGTH(ANS)=1
- IF $GET(X1(ANS,1))'=""
- IF $ORDER(X1(ANS,1))
- SET OVER=1
- WRITE " Ambiguous answer, enter the number."
- QUIT
- +9 SET OVER=1
- +10 QUIT
- +11 ;
- LST ; -- List previous selections and selections to choose from.
- +1 NEW I,CNT,IBQUIT,NUM
- +2 ;
- +3 ; -- list previous selections
- +4 DO PREVSEL
- +5 ;
- +6 ; -- list available choices
- +7 SET (IBQUIT,CNT)=0
- +8 SET NUM=+$$CHOICE^IBDFDE2(0)
- +9 WRITE !!,"Choose from: "
- +10 SET I=0
- FOR
- SET I=$ORDER(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I))
- if 'I!(IBQUIT)
- QUIT
- Begin DoDot:1
- +11 SET CHOICE=$$CHOICE^IBDFDE2(I)
- +12 IF '$PIECE(CHOICE,"^",7)
- WRITE !?16,IOINHI,$PIECE(CHOICE,"^"),IOINORM
- QUIT
- +13 SET CNT=CNT+1
- SET NUMBER(CNT)=I
- +14 WRITE !?3,CNT,?7,$SELECT($PIECE(CHOICE,"^",2)'="":$PIECE(CHOICE,"^",2),1:$PIECE(CHOICE,"^",3)),?16,$PIECE(CHOICE,"^",1)
- +15 IF NUM>15
- IF NUM>I
- IF '(CNT#15)
- DO PAUSE^IBDFDE
- IF 'IBQUIT
- WRITE $CHAR(13),$JUSTIFY("",55),$CHAR(13)
- +16 ;I NUM>15,CNT'=NUM,'(CNT#15) D READ I $G(LISTSEL)<1!($G(LISTSEL)>CNT) K LISTSEL
- +17 ;I $G(LISTSEL) S SEL=NUMBER(LISTSEL)
- End DoDot:1
- +18 QUIT
- +19 ;
- PREVSEL ; -- List previous selections
- +1 NEW I,CNT
- +2 SET CNT=0
- +3 ;
- +4 ; -- list previous selections
- +5 IF $DATA(IBDPI(IBDF("PI")))>1
- SET I=0
- FOR
- SET I=$ORDER(IBDPI(IBDF("PI"),I))
- if 'I
- QUIT
- Begin DoDot:1
- +6 ; not the same list
- if $PIECE(IBDPI(IBDF("PI"),I),"^",7)'=IBDF("IEN")
- QUIT
- +7 SET CNT=CNT+1
- +8 if CNT=1
- WRITE !!,IOINHI," You have previously selected: ",IOINORM
- +9 WRITE !,?7,$SELECT($PIECE($GET(^IBE(357.6,+IBDPI(IBDF("PI"),I),0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX^IBDFDE1($PIECE(IBDPI(IBDF("PI"),I),"^",2)),1:$PIECE(IBDPI(IBDF("PI"),I),"^",2))
- +10 WRITE ?16,$PIECE(IBDPI(IBDF("PI"),I),"^",3),?50,$PIECE(IBDPI(IBDF("PI"),I),"^",6)
- End DoDot:1
- +11 WRITE !
- +12 QUIT
- +13 ;
- DEFAULT ; -- compute default answer
- +1 NEW CNT,SEL,NAME,PIECE,SELAST
- +2 SET (CNT,SEL,SELAST)=0
- +3 SET NAME=$PIECE($GET(^IBE(357.6,+IBDF("PI"),0)),"^")
- +4 SET PIECE=$SELECT(NAME["INPUT PROCEDURE CODE":2,NAME["INPUT DIAGNOSIS CODE":2,NAME["INPUT VISIT TYPE":2,1:3)
- +5 FOR
- SET SEL=$ORDER(IBDPI(IBDF("PI"),SEL))
- if 'SEL
- QUIT
- Begin DoDot:1
- +6 ; not the same list
- if $PIECE(IBDPI(IBDF("PI"),SEL),"^",7)'=IBDF("IEN")
- QUIT
- +7 SET CNT=CNT+1
- SET SELAST=SEL
- End DoDot:1
- +8 IF $GET(SELAST)
- SET DIR("B")=$PIECE(IBDPI(IBDF("PI"),SELAST),"^",PIECE)
- SET IBDEFLT(IBDF("PI"))=DIR("B")
- +9 DO PREVSEL
- +10 QUIT
- +11 ;
- DEFPROV ; -- find default provider, not on form
- +1 NEW SEL,IBDX
- +2 SET IBDF("PI")=$ORDER(^IBE(357.6,"B","INPUT PROVIDER",0))
- +3 if $DATA(IBDPI(IBDF("PI")))
- QUIT
- +4 SET SEL=$GET(IBDF("PROVIDER"))
- IF 'SEL
- SET SEL=$$PRDEF^IBDFRPC3(IBDF("CLINIC"))
- +5 if 'SEL
- QUIT
- +6 ;flag not on form
- SET $PIECE(IBDF("PROVIDER PI"),"^",2)=1
- +7 SET IBDX=$GET(IBDSEL(0))+1
- SET IBDSEL(0)=IBDX
- +8 SET IBDSEL(IBDX)=IBDF("PI")_"^"_SEL_"^"_$PIECE($GET(^VA(200,+SEL,0)),"^")_"^^^PRIMARY^"
- +9 SET IBDPI(IBDF("PI"),IBDX)=IBDSEL(IBDX)
- +10 if '$GET(IBDF("PROVIDER"))
- WRITE !!,"No Provider Block on form. Using Default Provider from Clinic as Primary.",!
- +11 if $GET(IBDF("PROVIDER"))
- WRITE !!,"Using Provider: "
- +12 WRITE " ",$PIECE(^VA(200,+SEL,0),"^")," PRIMARY",!
- +13 QUIT
- +14 ;
- HELP ; --
- +1 WRITE !,"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).",!
- +2 QUIT
- +3 ;
- OTHER(IBDX) ; -- allow input of an additional item
- +1 NEW I,J,X,Y,DIR,DIRUT,DUOUT,SEL,SELX,NARR,DIC,DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX,IBDFILE,IBDIMP,IBDCSYS,IBDX
- +2 ;
- +3 ; -- strip the cpt code if modifiers are added cpt-mod,mod,mod...
- +4 ;
- +5 IF IBDX["-"
- SET IBDX=$PIECE(IBDX,"-")
- +6 IF $GET(IBDF("LEXICON"))
- Begin DoDot:1
- +7 IF $DATA(^LEX)>1
- SET X="LEXSET"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO CONFIG^LEXSET("ICD","ICD")
- SET IBDLEX=1
- +8 IF '$DATA(IBDLEX)
- SET X="GMPTSET"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO CONFIG^GMPTSET("GMPL","PL1")
- SET IBDLEX=1
- +9 ;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)
- End DoDot:1
- if '$DATA(IBDLEX)
- QUIT
- +10 SET SELX=-1
- +11 IF '$GET(IBDF("OTHER"))
- GOTO OTHQ
- +12 IF $LENGTH($GET(IBDX))
- SET X=IBDX
- SET DIC(0)="EQMZ"
- +13 SET DIC("A")="Select Other "_$GET(IBDASK)
- +14 SET DIC=$PIECE(IBDF("OTHER"),"^")
- IF $PIECE(IBDF("OTHER"),"^",2)'=""
- SET DIC("S")=$PIECE(IBDF("OTHER"),"^",2,99)
- +15 DO ^DIC
- if +Y<1
- GOTO OTHQ
- +16 KILL DIC
- +17 SET SEL=Y
- +18 WRITE !!,$CHAR(7),"WARNING: Item selected not from Encounter Form."
- +19 ;
- +20 IF IBDF("PI")=$GET(IBDF("PROVIDER PI"))
- WRITE !
- SET SELX=$PIECE($GET(^VA(200,+Y,0)),"^",1)_"^^"_+Y_"^^^^1"
- GOTO OTHQ
- +21 ;
- +22 WRITE "...Entry of Narrative Required!",!
- +23 SET IBDFILE=+IBDF("OTHER")
- +24 if IBDFILE=81
- SET DIR("B")=$PIECE(Y(0),"^",2)
- +25 if IBDFILE=80
- SET IBDIMP=$$IMPDATE^IBDUTICD(30)
- SET IBDCSYS=$SELECT(DT'<IBDIMP:30,1:1)
- SET IBDX=$PIECE($$ICDDATA^ICDXCODE(IBDCSYS,+Y,DT),U,4)
- +26 if IBDFILE=80
- SET DIR("B")=$SELECT($LENGTH(IBDX)<81:IBDX,1:$PIECE(Y(0),"^",3))
- +27 if IBDFILE=357.69
- SET DIR("B")=$PIECE(Y(0),"^",3)
- +28 IF IBDFILE>9999999
- IF IBDFILE<10000000
- SET DIR("B")=$PIECE(Y(0),"^",1)
- +29 SET DIR(0)="FO^3:80"
- SET DIR("A")="Narrative"
- DO ^DIR
- KILL DIR
- if $GET(DIRUT)
- GOTO OTHQ
- +30 SET NARR=Y
- +31 ;
- +32 SET SELX=$SELECT((IBDFILE<9999999)&(IBDFILE'=757.01):NARR_"^^"_$PIECE(SEL,"^",2)_"^^^^1",1:NARR_"^^"_$PIECE(SEL,"^",1)_"^^^^1")
- OTHQ QUIT $SELECT(SELX=-1:"",1:SELX)
- +1 ;
- PARTLST(ARY,NEXT,ANS) ; -- input has more than one match, prompt for which one
- +1 NEW I,J,K,N,IBD,ANS2,SEL,CHOICE
- +2 SET SEL=0
- +3 SET NEXT=$EXTRACT(NEXT,1,$LENGTH(NEXT)-1)_$CHAR($ASCII($EXTRACT(NEXT,$LENGTH(NEXT)))-1)_"~"
- +4 ;
- +5 SET J=0
- SET K=NEXT
- FOR
- SET K=$ORDER(@ARY@(K))
- if $EXTRACT(K,1,$LENGTH(ANS))'=ANS
- QUIT
- Begin DoDot:1
- +6 SET N=0
- FOR
- SET N=$ORDER(@ARY@(K,N))
- if 'N
- QUIT
- Begin DoDot:2
- +7 SET J=J+1
- SET IBD(J)=@ARY@(K,N)
- SET CHOICE=$$CHOICE^IBDFDE2(IBD(J))
- +8 WRITE !?6,J,?10,$SELECT($PIECE(CHOICE,"^",2)'="":$PIECE(CHOICE,"^",2),1:$PIECE(CHOICE,"^",3)),?20,$PIECE(CHOICE,"^",1),?50," ",$PIECE(CHOICE,"^",8)," ",$PIECE(CHOICE,"^",4)
- End DoDot:2
- End DoDot:1
- +9 ;
- ASKNUM IF J<1
- GOTO PARTLQ
- +1 WRITE !," Choose 1-",J,": "
- READ ANS2:DTIME
- +2 IF '$TEST!($EXTRACT(ANS2,1)="^")!(ANS2="")
- SET SEL=""
- GOTO PARTLQ
- +3 IF $EXTRACT(ANS2,1)="?"
- WRITE !,"Enter a number from 1 - ",J
- GOTO ASKNUM
- +4 SET ANS2=+ANS2
- +5 IF ANS2<1!(ANS2>J)
- GOTO ASKNUM
- +6 IF $GET(IBD(ANS2))=""
- GOTO ASKNUM
- +7 WRITE !
- +8 SET SEL=$GET(IBD(ANS2))
- PARTLQ QUIT SEL
- +1 ;
- READ ; -- get input from list
- +1 NEW ANS2
- +2 if CNT<1
- GOTO READQ
- +3 WRITE !," Choose 1-",CNT,": "
- READ ANS2:DTIME
- +4 IF '$TEST!($EXTRACT(ANS2,1)="^")
- SET IBQUIT=1
- GOTO READQ
- +5 IF $EXTRACT(ANS2,1)="?"
- WRITE !,"Enter a number from 1 - ",CNT," or return to see more."
- GOTO READ
- +6 SET ANS2=+ANS2
- +7 IF ANS2<1!(ANS2>CNT)
- WRITE $CHAR(7),!
- GOTO READ
- +8 IF $GET(NUMBER(CNT))=""
- GOTO READ
- +9 WRITE !
- READQ QUIT