IBDFDE4 ;ALB/AAS - AICS Manual Data Entry, process multiple choice fields ; 29-APR-96IOIN
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
% G ^IBDFDE
;
MULT(RESULT,IBDF) ; -- Procedure
; -- Manual Data entry routine for Multiple Choice Fields
; Input : Result := call by reference, used to output results
; IBDF("IEN") := pointer to hand print file (359.94)
; IBDF("PI") := pointer to input package interface
; IBDF("DFN") := pointer to patient
; IBDF("CLINIC") := pointer to hospital location
;
; output: Result(n) $p1 := pointer to package interface
;
N I,J,X,Y,ANS,DISPTXT,HDR,DIR,DIRUT,DUOUT,DTOUT,IBDX,QLFR,CHOICE,OVER
S X="IOINHI;IOINORM" D ENDR^%ZISS
S (IBQUIT,OVER)=0,(ANS,QLFR)=""
I $G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))="" D
.D OBJLST^IBDFRPC1(.CHOICE,.IBDF)
.M ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))=CHOICE
.K CHOICE
.D COMPLST^IBDFDE5
I +$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))<1 G MULTQ
S IBDASK=$P($P($G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",3),":")
I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
S RULE=+$P($G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",4)
;
OVER ; -- ask or re-ask for selection(s) from list
IF RULE=0 S DIR("?",1)="Any Number of "_$G(IOINHI)_IBDASK_$G(IOINORM)_" allowed (including zero)."
IF RULE=1 S DIR("?",1)="Exactly one "_$G(IOINHI)_IBDASK_$G(IOINORM)_" Required."
IF RULE=2 S DIR("?",1)="At most one "_$G(IOINHI)_IBDASK_$G(IOINORM)_" allowed."
IF RULE=3 S DIR("?")="At least 1 (1 or more) "_$G(IOINHI)_IBDASK_$G(IOINORM)_" Required."
;
S DIR("?",2)=""
S DIR("?")="Select an item from the form, enter by name or number. Enter '??' to see the choices. When editing, press enter to accept, '@' to delete, or enter a new selection."
;
S DIR("??")="^D LST^IBDFDE41"
;
S DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
I IBDASK[":" S $P(DIR(0),"^")="FOA"
S DIR("A")="Select "_$G(IBDASK)
D ^DIR K DIR
I $G(IBDEFLT(IBDF("PI")))'="",Y=IBDEFLT(IBDF("PI")) S Y="" ; on re-edit, accepting last entry same as entering nothing.
S ANS=$$UP^XLFSTR(Y)
I ANS="",$D(DIRUT),$G(IBDEFLT(IBDF("PI")))'="",$G(SELAST) K IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST) W " Deleted!" ;user type "@" at prompt
I ANS="" D CHK^IBDFDE42 G MCOVER
I ANS["^",ANS'="^" D G MCOVER
.S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
.I GOTO="?"!(GOTO="??") X "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX" S OVER=1 Q
.S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
.I X'="",X[GOTO W $E(X,$L(GOTO)+1,$L(X)) S IBDF("GOTO")=+$O(^TMP("IBD-ASK",$J,IBDFMIEN,X,""))-1,IBDREDIT=1 Q
.S IBQUIT=1
I $D(DIRUT) S IBQUIT=1 G MULTQ
S SELECT=0
;
;
; -- first check for exact code matches
I $G(NUMBER(ANS)) S SELECT=$G(NUMBER(ANS)) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
;
; -- check for exact text matches
S ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
I $G(@ARRAY@(ANS,1)),'$O(@ARRAY@(ANS,1)) S SELECT=@ARRAY@(ANS,1) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
I $G(@ARRAY@(ANS,1)) D I $G(SELECT) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
.; -- more than one description the same
.S SELECT=$$PARTLST^IBDFDE41(ARRAY,ANS,ANS)
;
; -- next check for paritial text answers
S NEXT=$O(@ARRAY@(ANS)) D I SELECT D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
.Q:NEXT=""!($E(NEXT,1,$L(ANS))'=ANS)
.I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS) Q
.S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS))=ANS S SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS) Q ;Not Unique answer
.W $E(NEXT,($L(ANS)+1),$L(NEXT))
.S SELECT=$G(@ARRAY@(NEXT,1))
;
I ANS'="" W " ?? ",$C(7),"Not Found" G OVER
;
MCOVER ;
G:OVER OVER
;
MULTQ ;
K ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
K ^TMP("IBD-LTEXT",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
K ^TMP("IBD-LCODE",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
K ^TMP("IB",$J,"INTERFACES")
K IBDF("OTHER"),ASKOTHER
Q
;
ASKYN(DIR) ; -- input dir
N ANS,X
D ^DIR
I $G(IBDREDIT),Y=$G(DIR("B")) S ANS=DIR("B") G ASKYNQ
K DIR
S ANS=$$UP^XLFSTR(Y)
I ANS="" G ASKYNQ
I ANS["^",ANS'="^" D G ASKYNQ
.S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
.S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
.;I GOTO="?"!(GOTO="??") X "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX" S OVER=1 Q
.I X'="",X[GOTO W $E(X,$L(GOTO)+1,$L(X)) S IBDF("GOTO")=+$O(^TMP("IBD-ASK",$J,IBDFMIEN,X,""))-1,IBDREDIT=1 Q
.S IBQUIT=1
I $D(DIRUT) S IBQUIT=1
ASKYNQ Q $G(ANS)
;
Q
TEST ;
S IBDFMIEN=9999
S IBDF("APPT")=2970331.1014
S IBDF("CLINIC")=300
S IBDF("DFN")=7169761
S IBDF("FORM")=33154
S IBDF("FRMDEF")=747
S IBDF("IBDF")=9
S IBDF("IEN")=213
S IBDF("TYPE")="MC"
S IBDF("PI")=92
D MULT(.RESULT,.IBDF)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE4 5101 printed Apr 09, 2024@21:55:34 Page 2
IBDFDE4 ;ALB/AAS - AICS Manual Data Entry, process multiple choice fields ; 29-APR-96IOIN
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
% GOTO ^IBDFDE
+1 ;
MULT(RESULT,IBDF) ; -- Procedure
+1 ; -- Manual Data entry routine for Multiple Choice Fields
+2 ; Input : Result := call by reference, used to output results
+3 ; IBDF("IEN") := pointer to hand print file (359.94)
+4 ; IBDF("PI") := pointer to input package interface
+5 ; IBDF("DFN") := pointer to patient
+6 ; IBDF("CLINIC") := pointer to hospital location
+7 ;
+8 ; output: Result(n) $p1 := pointer to package interface
+9 ;
+10 NEW I,J,X,Y,ANS,DISPTXT,HDR,DIR,DIRUT,DUOUT,DTOUT,IBDX,QLFR,CHOICE,OVER
+11 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+12 SET (IBQUIT,OVER)=0
SET (ANS,QLFR)=""
+13 IF $GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))=""
Begin DoDot:1
+14 DO OBJLST^IBDFRPC1(.CHOICE,.IBDF)
+15 MERGE ^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"))=CHOICE
+16 KILL CHOICE
+17 DO COMPLST^IBDFDE5
End DoDot:1
+18 IF +$GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))<1
GOTO MULTQ
+19 SET IBDASK=$PIECE($PIECE($GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",3),":")
+20 IF '$DATA(^TMP("IBD-ASK",$JOB,IBDFMIEN,IBDASK))
SET ^TMP("IBD-ASK",$JOB,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
+21 SET RULE=+$PIECE($GET(^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",4)
+22 ;
OVER ; -- ask or re-ask for selection(s) from list
+1 IF RULE=0
SET DIR("?",1)="Any Number of "_$GET(IOINHI)_IBDASK_$GET(IOINORM)_" allowed (including zero)."
+2 IF RULE=1
SET DIR("?",1)="Exactly one "_$GET(IOINHI)_IBDASK_$GET(IOINORM)_" Required."
+3 IF RULE=2
SET DIR("?",1)="At most one "_$GET(IOINHI)_IBDASK_$GET(IOINORM)_" allowed."
+4 IF RULE=3
SET DIR("?")="At least 1 (1 or more) "_$GET(IOINHI)_IBDASK_$GET(IOINORM)_" Required."
+5 ;
+6 SET DIR("?",2)=""
+7 SET DIR("?")="Select an item from the form, enter by name or number. Enter '??' to see the choices. When editing, press enter to accept, '@' to delete, or enter a new selection."
+8 ;
+9 SET DIR("??")="^D LST^IBDFDE41"
+10 ;
+11 SET DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
+12 IF IBDASK[":"
SET $PIECE(DIR(0),"^")="FOA"
+13 SET DIR("A")="Select "_$GET(IBDASK)
+14 DO ^DIR
KILL DIR
+15 ; on re-edit, accepting last entry same as entering nothing.
IF $GET(IBDEFLT(IBDF("PI")))'=""
IF Y=IBDEFLT(IBDF("PI"))
SET Y=""
+16 SET ANS=$$UP^XLFSTR(Y)
+17 ;user type "@" at prompt
IF ANS=""
IF $DATA(DIRUT)
IF $GET(IBDEFLT(IBDF("PI")))'=""
IF $GET(SELAST)
KILL IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST)
WRITE " Deleted!"
+18 IF ANS=""
DO CHK^IBDFDE42
GOTO MCOVER
+19 IF ANS["^"
IF ANS'="^"
Begin DoDot:1
+20 SET GOTO=$$UP^XLFSTR($PIECE(ANS,"^",2))
+21 IF GOTO="?"!(GOTO="??")
XECUTE "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX"
SET OVER=1
QUIT
+22 SET X=$ORDER(^TMP("IBD-ASK",$JOB,IBDFMIEN,GOTO))
+23 IF X'=""
IF X[GOTO
WRITE $EXTRACT(X,$LENGTH(GOTO)+1,$LENGTH(X))
SET IBDF("GOTO")=+$ORDER(^TMP("IBD-ASK",$JOB,IBDFMIEN,X,""))-1
SET IBDREDIT=1
QUIT
+24 SET IBQUIT=1
End DoDot:1
GOTO MCOVER
+25 IF $DATA(DIRUT)
SET IBQUIT=1
GOTO MULTQ
+26 SET SELECT=0
+27 ;
+28 ;
+29 ; -- first check for exact code matches
+30 IF $GET(NUMBER(ANS))
SET SELECT=$GET(NUMBER(ANS))
DO SEL^IBDFDE41(SELECT)
DO CHK^IBDFDE42
GOTO MCOVER
+31 ;
+32 ; -- check for exact text matches
+33 SET ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
+34 IF $GET(@ARRAY@(ANS,1))
IF '$ORDER(@ARRAY@(ANS,1))
SET SELECT=@ARRAY@(ANS,1)
DO SEL^IBDFDE41(SELECT)
DO CHK^IBDFDE42
GOTO MCOVER
+35 IF $GET(@ARRAY@(ANS,1))
Begin DoDot:1
+36 ; -- more than one description the same
+37 SET SELECT=$$PARTLST^IBDFDE41(ARRAY,ANS,ANS)
End DoDot:1
IF $GET(SELECT)
DO SEL^IBDFDE41(SELECT)
DO CHK^IBDFDE42
GOTO MCOVER
+38 ;
+39 ; -- next check for paritial text answers
+40 SET NEXT=$ORDER(@ARRAY@(ANS))
Begin DoDot:1
+41 if NEXT=""!($EXTRACT(NEXT,1,$LENGTH(ANS))'=ANS)
QUIT
+42 IF $ORDER(@ARRAY@(NEXT,1))
SET SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS)
QUIT
+43 ;Not Unique answer
SET NEXT1=$ORDER(@ARRAY@(NEXT))
IF $EXTRACT(NEXT1,1,$LENGTH(ANS))=ANS
SET SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS)
QUIT
+44 WRITE $EXTRACT(NEXT,($LENGTH(ANS)+1),$LENGTH(NEXT))
+45 SET SELECT=$GET(@ARRAY@(NEXT,1))
End DoDot:1
IF SELECT
DO SEL^IBDFDE41(SELECT)
DO CHK^IBDFDE42
GOTO MCOVER
+46 ;
+47 IF ANS'=""
WRITE " ?? ",$CHAR(7),"Not Found"
GOTO OVER
+48 ;
MCOVER ;
+1 if OVER
GOTO OVER
+2 ;
MULTQ ;
+1 KILL ^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
+2 KILL ^TMP("IBD-LTEXT",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
+3 KILL ^TMP("IBD-LCODE",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
+4 KILL ^TMP("IB",$JOB,"INTERFACES")
+5 KILL IBDF("OTHER"),ASKOTHER
+6 QUIT
+7 ;
ASKYN(DIR) ; -- input dir
+1 NEW ANS,X
+2 DO ^DIR
+3 IF $GET(IBDREDIT)
IF Y=$GET(DIR("B"))
SET ANS=DIR("B")
GOTO ASKYNQ
+4 KILL DIR
+5 SET ANS=$$UP^XLFSTR(Y)
+6 IF ANS=""
GOTO ASKYNQ
+7 IF ANS["^"
IF ANS'="^"
Begin DoDot:1
+8 SET GOTO=$$UP^XLFSTR($PIECE(ANS,"^",2))
+9 SET X=$ORDER(^TMP("IBD-ASK",$JOB,IBDFMIEN,GOTO))
+10 ;I GOTO="?"!(GOTO="??") X "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX" S OVER=1 Q
+11 IF X'=""
IF X[GOTO
WRITE $EXTRACT(X,$LENGTH(GOTO)+1,$LENGTH(X))
SET IBDF("GOTO")=+$ORDER(^TMP("IBD-ASK",$JOB,IBDFMIEN,X,""))-1
SET IBDREDIT=1
QUIT
+12 SET IBQUIT=1
End DoDot:1
GOTO ASKYNQ
+13 IF $DATA(DIRUT)
SET IBQUIT=1
ASKYNQ QUIT $GET(ANS)
+1 ;
+2 QUIT
TEST ;
+1 SET IBDFMIEN=9999
+2 SET IBDF("APPT")=2970331.1014
+3 SET IBDF("CLINIC")=300
+4 SET IBDF("DFN")=7169761
+5 SET IBDF("FORM")=33154
+6 SET IBDF("FRMDEF")=747
+7 SET IBDF("IBDF")=9
+8 SET IBDF("IEN")=213
+9 SET IBDF("TYPE")="MC"
+10 SET IBDF("PI")=92
+11 DO MULT(.RESULT,.IBDF)
+12 QUIT
