- 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 Feb 19, 2025@00:18:46 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