IBDFDE61 ;ALB/AAS - AICS Manual Data Entry, process selection lists ; 24-FEB-96
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
% G ^IBDFDE6
;
PARTLST(NEXT,ANS) ; -- user gave inexact match, find which one
;
N I,J,K,IBD,ANS2,SEL
S J=1,I=^TMP("IBD-PLN",$J,IBDF("CLINIC"),NEXT),IBD(J)=I,SEL=""
D ONE^IBDFDE6(I,J)
;
S K=NEXT F S K=$O(^TMP("IBD-PLN",$J,IBDF("CLINIC"),K)) Q:$E(K,1,$L(ANS))'=ANS D
.S J=J+1,IBD(J)=^TMP("IBD-PLN",$J,IBDF("CLINIC"),K)
.D ONE^IBDFDE6(IBD(J),J)
;
ASKNUM G:J<1 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 I ANS2="^" S IBQUIT=1
Q SEL
;
MULT(CNT,IBD) ; -- multiple appointment
N IBDI,ANS2,RESULT
I 'CNT!'$D(IBD) Q ""
S RESULT=""
; -- Loop through appointments, same date, same clinic
F IBDI=1:1:CNT S NODE=$G(^TMP(ARRAY,$J,IBDF("CLINIC"),$P(IBD(IBDI),"^",2),+IBD(IBDI))) Q:NODE']"" D ONE^IBDFDE6(NODE,IBDI)
;
ASKN G:CNT<1 MULTQ
W !," Choose 1-",CNT,": " R ANS2:DTIME
I '$T!($E(ANS2,1)="^")!(ANS2="") G MULTQ
I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",CNT G ASKN
S ANS2=+ANS2
I ANS2<1!(ANS2>CNT) G ASKN
I $G(IBD(ANS2))="" G ASKN
W !
S RESULT=$G(^TMP(ARRAY,$J,IBDF("CLINIC"),$P(IBD(ANS2),"^",2),+IBD(ANS2)))
MULTQ I ANS2="^" S IBQUIT=1
Q RESULT
;
ASKPT(CNT) ; -- select patient from list
Q:$G(IBQUIT)
N I,DIR,DIRUT,DUOUT,DTOUT ;F I=1:1 Q:($Y>(IOSL-3)) W !
I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR S IBQUIT='Y
Q
;
W !," Choose 1-",CNT,": " R ANS2:DTIME
I '$T!($E(ANS2,1)="^")!(ANS2="") S SEL="" G MULTQ
I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",CNT G ASKN
S ANS2=+ANS2
I ANS2<1!(ANS2>CNT) G ASKN
I $G(IBD(ANS2))="" G ASKN
W !
S RESULT=$G(IBD(ANS2))
Q RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE61 1923 printed Dec 13, 2024@02:52:24 Page 2
IBDFDE61 ;ALB/AAS - AICS Manual Data Entry, process selection lists ; 24-FEB-96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
% GOTO ^IBDFDE6
+1 ;
PARTLST(NEXT,ANS) ; -- user gave inexact match, find which one
+1 ;
+2 NEW I,J,K,IBD,ANS2,SEL
+3 SET J=1
SET I=^TMP("IBD-PLN",$JOB,IBDF("CLINIC"),NEXT)
SET IBD(J)=I
SET SEL=""
+4 DO ONE^IBDFDE6(I,J)
+5 ;
+6 SET K=NEXT
FOR
SET K=$ORDER(^TMP("IBD-PLN",$JOB,IBDF("CLINIC"),K))
if $EXTRACT(K,1,$LENGTH(ANS))'=ANS
QUIT
Begin DoDot:1
+7 SET J=J+1
SET IBD(J)=^TMP("IBD-PLN",$JOB,IBDF("CLINIC"),K)
+8 DO ONE^IBDFDE6(IBD(J),J)
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 IF ANS2="^"
SET IBQUIT=1
+1 QUIT SEL
+2 ;
MULT(CNT,IBD) ; -- multiple appointment
+1 NEW IBDI,ANS2,RESULT
+2 IF 'CNT!'$DATA(IBD)
QUIT ""
+3 SET RESULT=""
+4 ; -- Loop through appointments, same date, same clinic
+5 FOR IBDI=1:1:CNT
SET NODE=$GET(^TMP(ARRAY,$JOB,IBDF("CLINIC"),$PIECE(IBD(IBDI),"^",2),+IBD(IBDI)))
if NODE']""
QUIT
DO ONE^IBDFDE6(NODE,IBDI)
+6 ;
ASKN if CNT<1
GOTO MULTQ
+1 WRITE !," Choose 1-",CNT,": "
READ ANS2:DTIME
+2 IF '$TEST!($EXTRACT(ANS2,1)="^")!(ANS2="")
GOTO MULTQ
+3 IF $EXTRACT(ANS2,1)="?"
WRITE !,"Enter a number from 1 - ",CNT
GOTO ASKN
+4 SET ANS2=+ANS2
+5 IF ANS2<1!(ANS2>CNT)
GOTO ASKN
+6 IF $GET(IBD(ANS2))=""
GOTO ASKN
+7 WRITE !
+8 SET RESULT=$GET(^TMP(ARRAY,$JOB,IBDF("CLINIC"),$PIECE(IBD(ANS2),"^",2),+IBD(ANS2)))
MULTQ IF ANS2="^"
SET IBQUIT=1
+1 QUIT RESULT
+2 ;
ASKPT(CNT) ; -- select patient from list
+1 if $GET(IBQUIT)
QUIT
+2 ;F I=1:1 Q:($Y>(IOSL-3)) W !
NEW I,DIR,DIRUT,DUOUT,DTOUT
+3 IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
SET IBQUIT='Y
+4 QUIT
+5 ;
+6 WRITE !," Choose 1-",CNT,": "
READ ANS2:DTIME
+7 IF '$TEST!($EXTRACT(ANS2,1)="^")!(ANS2="")
SET SEL=""
GOTO MULTQ
+8 IF $EXTRACT(ANS2,1)="?"
WRITE !,"Enter a number from 1 - ",CNT
GOTO ASKN
+9 SET ANS2=+ANS2
+10 IF ANS2<1!(ANS2>CNT)
GOTO ASKN
+11 IF $GET(IBD(ANS2))=""
GOTO ASKN
+12 WRITE !
+13 SET RESULT=$GET(IBD(ANS2))
+14 QUIT RESULT
