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

IBDFDE4.m

Go to the documentation of this file. 
  1. IBDFDE4 ;ALB/AAS - AICS Manual Data Entry, process multiple choice fields ; 29-APR-96IOIN
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1.  ;
  1. % G ^IBDFDE
  1.  ;
  1. MULT(RESULT,IBDF) ; -- Procedure
  1.  ; -- Manual Data entry routine for Multiple Choice Fields
  1.  ;    Input :  Result := call by reference, used to output results
  1.  ;             IBDF("IEN")    := pointer to hand print file (359.94)
  1.  ;             IBDF("PI")     := pointer to input package interface
  1.  ;             IBDF("DFN")    := pointer to patient
  1.  ;             IBDF("CLINIC") := pointer to hospital location
  1.  ;
  1.  ;    output:  Result(n)  $p1 := pointer to package interface
  1.  ;
  1.  N I,J,X,Y,ANS,DISPTXT,HDR,DIR,DIRUT,DUOUT,DTOUT,IBDX,QLFR,CHOICE,OVER
  1.  S X="IOINHI;IOINORM" D ENDR^%ZISS
  1.  S (IBQUIT,OVER)=0,(ANS,QLFR)=""
  1.  I $G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))="" D
  1.  .D OBJLST^IBDFRPC1(.CHOICE,.IBDF)
  1.  .M ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))=CHOICE
  1.  .K CHOICE
  1.  .D COMPLST^IBDFDE5
  1.  I +$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))<1 G MULTQ
  1.  S IBDASK=$P($P($G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",3),":")
  1.  I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
  1.  S RULE=+$P($G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",4)
  1.  ;
  1. OVER ; -- ask or re-ask for selection(s) from list
  1.  IF RULE=0 S DIR("?",1)="Any Number of "_$G(IOINHI)_IBDASK_$G(IOINORM)_" allowed (including zero)."
  1.  IF RULE=1 S DIR("?",1)="Exactly one "_$G(IOINHI)_IBDASK_$G(IOINORM)_" Required."
  1.  IF RULE=2 S DIR("?",1)="At most one "_$G(IOINHI)_IBDASK_$G(IOINORM)_" allowed."
  1.  IF RULE=3 S DIR("?")="At least 1 (1 or more) "_$G(IOINHI)_IBDASK_$G(IOINORM)_" Required."
  1.  ;
  1.  S DIR("?",2)=""
  1.  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."
  1.  ;
  1.  S DIR("??")="^D LST^IBDFDE41"
  1.  ;
  1.  S DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
  1.  I IBDASK[":" S $P(DIR(0),"^")="FOA"
  1.  S DIR("A")="Select "_$G(IBDASK)
  1.  D ^DIR K DIR
  1.  I $G(IBDEFLT(IBDF("PI")))'="",Y=IBDEFLT(IBDF("PI")) S Y="" ; on re-edit, accepting last entry same as entering nothing.
  1.  S ANS=$$UP^XLFSTR(Y)
  1.  I ANS="",$D(DIRUT),$G(IBDEFLT(IBDF("PI")))'="",$G(SELAST) K IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST) W "  Deleted!" ;user type "@" at prompt
  1.  I ANS="" D CHK^IBDFDE42 G MCOVER
  1.  I ANS["^",ANS'="^" D  G MCOVER
  1.  .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
  1.  .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
  1.  .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
  1.  .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
  1.  .S IBQUIT=1
  1.  I $D(DIRUT) S IBQUIT=1 G MULTQ
  1.  S SELECT=0
  1.  ;
  1.  ;
  1.  ; -- first check for exact code matches
  1.  I $G(NUMBER(ANS)) S SELECT=$G(NUMBER(ANS)) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
  1.  ;
  1.  ; -- check for exact text matches
  1.  S ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
  1.  I $G(@ARRAY@(ANS,1)),'$O(@ARRAY@(ANS,1)) S SELECT=@ARRAY@(ANS,1)  D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
  1.  I $G(@ARRAY@(ANS,1)) D  I $G(SELECT) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
  1.  .; -- more than one description the same
  1.  .S SELECT=$$PARTLST^IBDFDE41(ARRAY,ANS,ANS)
  1.  ;
  1.  ; -- next check for paritial text answers
  1.  S NEXT=$O(@ARRAY@(ANS)) D  I SELECT D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
  1.  .Q:NEXT=""!($E(NEXT,1,$L(ANS))'=ANS)
  1.  .I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS) Q
  1.  .S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS))=ANS S SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS) Q  ;Not Unique answer
  1.  .W $E(NEXT,($L(ANS)+1),$L(NEXT))
  1.  .S SELECT=$G(@ARRAY@(NEXT,1))
  1.  ;
  1.  I ANS'="" W " ??  ",$C(7),"Not Found" G OVER
  1.  ;
  1. MCOVER ;
  1.  G:OVER OVER
  1.  ;
  1. MULTQ ;
  1.  K ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
  1.  K ^TMP("IBD-LTEXT",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
  1.  K ^TMP("IBD-LCODE",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
  1.  K ^TMP("IB",$J,"INTERFACES")
  1.  K IBDF("OTHER"),ASKOTHER
  1.  Q
  1.  ;
  1. ASKYN(DIR) ; -- input dir
  1.  N ANS,X
  1.  D ^DIR
  1.  I $G(IBDREDIT),Y=$G(DIR("B")) S ANS=DIR("B") G ASKYNQ
  1.  K DIR
  1.  S ANS=$$UP^XLFSTR(Y)
  1.  I ANS="" G ASKYNQ
  1.  I ANS["^",ANS'="^" D  G ASKYNQ
  1.  .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
  1.  .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
  1.  .;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
  1.  .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
  1.  .S IBQUIT=1
  1.  I $D(DIRUT) S IBQUIT=1
  1. ASKYNQ Q $G(ANS)
  1.  ;
  1.  Q
  1. TEST ;
  1.  S IBDFMIEN=9999
  1.  S IBDF("APPT")=2970331.1014
  1.  S IBDF("CLINIC")=300
  1.  S IBDF("DFN")=7169761
  1.  S IBDF("FORM")=33154
  1.  S IBDF("FRMDEF")=747
  1.  S IBDF("IBDF")=9
  1.  S IBDF("IEN")=213
  1.  S IBDF("TYPE")="MC"
  1.  S IBDF("PI")=92
  1.  D MULT(.RESULT,.IBDF)
  1.  Q