Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFDE41

IBDFDE41.m

Go to the documentation of this file.
  1. IBDFDE41 ;ALB/AAS - AICS Data Entry, process selection lists ;02/24/96 [ 11/13/96 3:58 PM ]
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
  1. ;
  1. ;
  1. % G ^IBDFDE
  1. ;
  1. SEL(SEL) ; -- Build results array
  1. N IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR,IBDIMP,IBDIBX
  1. S IBDIMP=$$IMPDATE^IBDUTICD(30)
  1. S IBDIBX=799.9
  1. I DT'<IBDIMP S IBDIBX="R69."
  1. S IBQUIT=0
  1. ;
  1. I +SEL=SEL S CHOICE=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),SEL))
  1. I +SEL'=SEL S CHOICE=SEL
  1. Q:IBQUIT
  1. ;
  1. ; -- build selections
  1. S RESULT(0)=$G(RESULT(0))+1
  1. W " ",$P(CHOICE,"^")," ",$P(CHOICE,"^",3)
  1. ;
  1. S RESULT(RESULT(0))=IBDF("PI")_"^"_$P(CHOICE,"^",4)_"^"_$P(CHOICE,"^")_"^^^"_$P(CHOICE,"^",3)_"^"_$G(IBDF("IEN"))
  1. S IBDPI(IBDF("PI"),RESULT(0))=RESULT(RESULT(0))
  1. ;
  1. ; --validate code for active problem list
  1. I $P($G(^IBE(357.6,IBDF("PI"),0)),"^")="PX INPUT PATIENT ACTIVE PROBLEM" D
  1. .N X S X=$P(CHOICE,"^",2) Q:X=""
  1. .I X=IBDIBX W !,$C(7),$G(IOINHI),"Warning: The ICD",$S(DT'<IBDIMP:"10",1:"9")," Diagnosis associated with this problem needs to be updated!",$G(IOINORM) Q
  1. .D TESTICD^IBDFN7
  1. .I '$D(X) W !,$C(7),$G(IOINHI),"Warning: The ICD",$S(DT'<IBDIMP:"10",1:"9")," code associated with this problem is inactive.",$G(IOINORM)
  1. ;
  1. Q
  1. ;
  1. LST ; -- List previous selections and selections to choose from.
  1. N I,CNT,IBQUIT,NUM
  1. ;
  1. ; -- list previous selections
  1. D PREVSEL
  1. ;
  1. ; -- list available choices
  1. S (IBQUIT,CNT)=0
  1. S NUM=+$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))
  1. W !!,"Choose from: "
  1. S I=0 F S I=$O(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I)) Q:'I!(IBQUIT) D
  1. .S CHOICE=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I))
  1. .S CNT=CNT+1,NUMBER(CNT)=I
  1. .W !?3,CNT,?7,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^")),?20," ",$P(CHOICE,"^",3)
  1. .I NUM>15,NUM>I,'(CNT#15) D PAUSE^IBDFDE I 'IBQUIT W $C(13),$J("",55),$C(13)
  1. Q
  1. ;
  1. PREVSEL ; -- List previous selections
  1. N I,CNT
  1. S CNT=0
  1. ;
  1. ; -- list previous selections
  1. I $D(IBDPI(IBDF("PI")))>1 S I=0 F S I=$O(IBDPI(IBDF("PI"),I)) Q:'I D
  1. .Q:$P(IBDPI(IBDF("PI"),I),"^",7)'=IBDF("IEN") ; not the same list
  1. .S CNT=CNT+1
  1. .W:CNT=1 !!,IOINHI," You have previously selected: ",IOINORM
  1. .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))
  1. .W ?16,$P(IBDPI(IBDF("PI"),I),"^",3),?50,$P(IBDPI(IBDF("PI"),I),"^",6)
  1. W !
  1. Q
  1. ;
  1. DEFAULT ; -- compute default answer
  1. N CNT,SEL,NAME,PIECE,SELAST
  1. S (CNT,SEL,SELAST)=0
  1. S NAME=$P($G(^IBE(357.6,+IBDF("PI"),0)),"^")
  1. S PIECE=$S(NAME["INPUT PROCEDURE CODE":2,NAME["INPUT DIAGNOSIS CODE":2,NAME["INPUT VISIT TYPE":2,1:3)
  1. F S SEL=$O(IBDPI(IBDF("PI"),SEL)) Q:'SEL D
  1. .Q:$P(IBDPI(IBDF("PI"),SEL),"^",7)'=IBDF("IEN") ; not the same list
  1. .S CNT=CNT+1,SELAST=SEL
  1. I $G(SELAST) S DIR("B")=$P(IBDPI(IBDF("PI"),SELAST),"^",PIECE),IBDEFLT(IBDF("PI"))=DIR("B")
  1. D PREVSEL
  1. Q
  1. ;
  1. PARTLST(ARY,NEXT,ANS) ; -- input has more than one match, prompt for which one
  1. N I,J,K,N,IBD,ANS2,SEL,CHOICE
  1. S SEL=0
  1. S NEXT=$E(NEXT,1,$L(NEXT)-1)_$C($A($E(NEXT,$L(NEXT)))-1)_"~"
  1. ;
  1. S J=0,K=NEXT F S K=$O(@ARY@(K)) Q:$E(K,1,$L(ANS))'=ANS D
  1. .S N=0 F S N=$O(@ARY@(K,N)) Q:'N D
  1. ..S J=J+1,IBD(J)=@ARY@(K,N),CHOICE=$$CHOICE^IBDFDE2(IBD(J))
  1. ..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)
  1. ;
  1. ASKNUM I J<1 G PARTLQ
  1. W !," Choose 1-",J,": " R ANS2:DTIME
  1. I '$T!($E(ANS2,1)="^")!(ANS2="") S SEL="" G PARTLQ
  1. I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",J G ASKNUM
  1. S ANS2=+ANS2
  1. I ANS2<1!(ANS2>J) G ASKNUM
  1. I $G(IBD(ANS2))="" G ASKNUM
  1. W !
  1. S SEL=$G(IBD(ANS2))
  1. PARTLQ Q SEL