IBDFDE41 ;ALB/AAS - AICS Data Entry, process selection lists ;02/24/96 [ 11/13/96 3:58 PM ]
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
% G ^IBDFDE
;
SEL(SEL) ; -- Build results array
N IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR,IBDIMP,IBDIBX
S IBDIMP=$$IMPDATE^IBDUTICD(30)
S IBDIBX=799.9
I DT'<IBDIMP S IBDIBX="R69."
S IBQUIT=0
;
I +SEL=SEL S CHOICE=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),SEL))
I +SEL'=SEL S CHOICE=SEL
Q:IBQUIT
;
; -- build selections
S RESULT(0)=$G(RESULT(0))+1
W " ",$P(CHOICE,"^")," ",$P(CHOICE,"^",3)
;
S RESULT(RESULT(0))=IBDF("PI")_"^"_$P(CHOICE,"^",4)_"^"_$P(CHOICE,"^")_"^^^"_$P(CHOICE,"^",3)_"^"_$G(IBDF("IEN"))
S IBDPI(IBDF("PI"),RESULT(0))=RESULT(RESULT(0))
;
; --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),$G(IOINHI),"Warning: The ICD",$S(DT'<IBDIMP:"10",1:"9")," Diagnosis associated with this problem needs to be updated!",$G(IOINORM) Q
.D TESTICD^IBDFN7
.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)
;
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=+$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),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=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I))
.S CNT=CNT+1,NUMBER(CNT)=I
.W !?3,CNT,?7,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^")),?20," ",$P(CHOICE,"^",3)
.I NUM>15,NUM>I,'(CNT#15) D PAUSE^IBDFDE I 'IBQUIT W $C(13),$J("",55),$C(13)
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
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE41 3784 printed Apr 09, 2024@21:04:57 Page 2
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
+2 ;
+3 ;
% GOTO ^IBDFDE
+1 ;
SEL(SEL) ; -- Build results array
+1 NEW IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR,IBDIMP,IBDIBX
+2 SET IBDIMP=$$IMPDATE^IBDUTICD(30)
+3 SET IBDIBX=799.9
+4 IF DT'<IBDIMP
SET IBDIBX="R69."
+5 SET IBQUIT=0
+6 ;
+7 IF +SEL=SEL
SET CHOICE=$GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),SEL))
+8 IF +SEL'=SEL
SET CHOICE=SEL
+9 if IBQUIT
QUIT
+10 ;
+11 ; -- build selections
+12 SET RESULT(0)=$GET(RESULT(0))+1
+13 WRITE " ",$PIECE(CHOICE,"^")," ",$PIECE(CHOICE,"^",3)
+14 ;
+15 SET RESULT(RESULT(0))=IBDF("PI")_"^"_$PIECE(CHOICE,"^",4)_"^"_$PIECE(CHOICE,"^")_"^^^"_$PIECE(CHOICE,"^",3)_"^"_$GET(IBDF("IEN"))
+16 SET IBDPI(IBDF("PI"),RESULT(0))=RESULT(RESULT(0))
+17 ;
+18 ; --validate code for active problem list
+19 IF $PIECE($GET(^IBE(357.6,IBDF("PI"),0)),"^")="PX INPUT PATIENT ACTIVE PROBLEM"
Begin DoDot:1
+20 NEW X
SET X=$PIECE(CHOICE,"^",2)
if X=""
QUIT
+21 IF X=IBDIBX
WRITE !,$CHAR(7),$GET(IOINHI),"Warning: The ICD",$SELECT(DT'<IBDIMP:"10",1:"9")," Diagnosis associated with this problem needs to be updated!",$GET(IOINORM)
QUIT
+22 DO TESTICD^IBDFN7
+23 IF '$DATA(X)
WRITE !,$CHAR(7),$GET(IOINHI),"Warning: The ICD",$SELECT(DT'<IBDIMP:"10",1:"9")," code associated with this problem is inactive.",$GET(IOINORM)
End DoDot:1
+24 ;
+25 QUIT
+26 ;
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=+$GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),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=$GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I))
+12 SET CNT=CNT+1
SET NUMBER(CNT)=I
+13 WRITE !?3,CNT,?7,$SELECT($PIECE(CHOICE,"^",2)'="":$PIECE(CHOICE,"^",2),1:$PIECE(CHOICE,"^")),?20," ",$PIECE(CHOICE,"^",3)
+14 IF NUM>15
IF NUM>I
IF '(CNT#15)
DO PAUSE^IBDFDE
IF 'IBQUIT
WRITE $CHAR(13),$JUSTIFY("",55),$CHAR(13)
End DoDot:1
+15 QUIT
+16 ;
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 ;
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
