- IBDFU8 ;ALB/CJM - ENCOUNTER FORM - selection routines for form components;OCT 8,1993
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- SLCTBLK(FORM,SCRNSIZE,EXCLUDE) ;SCRNSIZE is the number of lines available for scrolling
- ;EXCLUDE is a block name that can be excluded (used to exclude the HEADER block from being edited)
- ;returns the block selected, returns "" if none selected
- ;only allows one to be selected
- ;
- Q:'FORM
- S SCRNSIZE=+$G(SCRNSIZE)-1
- S:SCRNSIZE<1 SCRNSIZE=4
- S EXCLUDE=$G(EXCLUDE)
- N COUNT,CNT,PICK,BLK,ARY,NAME
- S ARY="^TMP($J,""FORM BLOCKS"")"
- K @ARY
- S CNT=$$FINDALL ;FORM,EXCLUDE,ARY are inputs to FINDALL
- ;
- ;if CNT=1 return the only block
- I CNT=1 S NAME=$O(@ARY@("NAME","")) Q $S(NAME'="":$O(@ARY@("NAME",NAME,0)),1:"")
- ;
- ;if CNT'=1 loop through the blocks, displaying them to the user and let him choose
- AGAIN ;
- S (PICK,NAME)="",COUNT=0
- F S NAME=$O(@ARY@("NAME",NAME)) Q:(PICK'="")!(NAME="") D
- .S BLK=0 F S BLK=$O(@ARY@("NAME",NAME,BLK)) Q:(PICK'="")!('BLK) D Q:NAME=""
- ..S COUNT=COUNT+1,@ARY@("#",COUNT)=BLK W !,COUNT," ",NAME,?38,$E($P($G(^IBE(357.1,BLK,0)),"^",13),1,42)
- ..I COUNT#SCRNSIZE=0 S PICK=$$CHOOSE
- I (PICK=""),COUNT,COUNT#SCRNSIZE'=0 S PICK=$$CHOOSE
- I PICK="" K DIR S DIR(0)="Y",DIR("A")="No block selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
- I PICK="?" G AGAIN
- K @ARY
- Q $S((PICK'>0):"",1:PICK)
- ;
- FINDALL() ;finds all of the blocks on FORM (except the one named EXCLUDE) and puts them on @ARY,returns the cound
- N BLK,COUNT,NODE
- S BLK="",COUNT=0 F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK S NODE=$G(^IBE(357.1,BLK,0)),NAME=$P(NODE,"^") S:(NAME'="")&(NAME'=EXCLUDE)&($P(NODE,"^",2)=FORM) @ARY@("NAME",$$UP^XLFSTR(NAME),BLK)="",COUNT=COUNT+1
- Q COUNT
- ;
- CHOOSE() ;asks the user to select a blk - @ARY@("#", is the aray of blocks displayed so far(subscripted by the number on the list), @ARY@("NAME", the entire array (subscripted by name,ien)
- ;sets NAME to " " and COUNT to 0 if ? is entered - starts display of list over
- N ANS,QUIT,PICK,NEXT1,NEXT2
- S QUIT=0
- F Q:QUIT D D:'QUIT MSG
- .S (PICK,ANS)=""
- .W !,"Choose 1-",COUNT,$S(COUNT<CNT:" or hit RETURN to see more",1:""),": "
- .R ANS:DTIME
- .I '$T!($E(ANS,1)="^") S PICK=-1,QUIT=1 Q
- .I ANS="" S QUIT=1 Q
- .I $E(ANS,1)="?" D HELP Q
- .;
- .;convert to upper case
- .S ANS=$$UP^XLFSTR(ANS)
- .
- .;if user entered a displayed number then he's made his choice
- .I $D(@ARY@("#",ANS)) S PICK=$G(@ARY@("#",ANS)),QUIT=1 Q
- .;
- .;if the user entered an exact name, and the name is unique then he's made his choice
- .S PICK=$O(@ARY@("NAME",ANS,PICK)) I PICK,'$O(@ARY@("NAME",ANS,PICK)) S QUIT=1 Q
- .Q:PICK ;don't set QUIT=1 because name is not unique
- .;
- .;if the user entered a partial name accept it if there is exactly one match
- .S NEXT1=$O(@ARY@("NAME",ANS)) Q:(NEXT1="")!($E(NEXT1,1,$L(ANS))'=ANS)
- .S NEXT2=$O(@ARY@("NAME",NEXT1)) Q:($E(NEXT2,1,$L(ANS))=ANS) ;because user did not type in enough to uniquely identify the block
- .;make sure there are not two blocks with the same name - if ok, accept it
- .S PICK=$O(@ARY@("NAME",NEXT1,PICK)) Q:'PICK I '$O(@ARY@("NAME",NEXT1,PICK)) S QUIT=1 Q
- Q PICK
- ;
- HELP ;choosing help restarts the display (by setting NAME="")
- W !,"You can choose a block by the number or by it's name.",!
- D PAUSE^IBDFU5
- S QUIT=1,NAME="",PICK="?",COUNT=0
- Q
- MSG ;
- W !,"You must enter the number or name of the block!"
- D PAUSE^IBDFU5
- Q
- IBDFU8 ;ALB/CJM - ENCOUNTER FORM - selection routines for form components;OCT 8,1993
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- SLCTBLK(FORM,SCRNSIZE,EXCLUDE) ;SCRNSIZE is the number of lines available for scrolling
- +1 ;EXCLUDE is a block name that can be excluded (used to exclude the HEADER block from being edited)
- +2 ;returns the block selected, returns "" if none selected
- +3 ;only allows one to be selected
- +4 ;
- +5 IF 'FORM
- QUIT
- +6 SET SCRNSIZE=+$GET(SCRNSIZE)-1
- +7 IF SCRNSIZE<1
- SET SCRNSIZE=4
- +8 SET EXCLUDE=$GET(EXCLUDE)
- +9 NEW COUNT,CNT,PICK,BLK,ARY,NAME
- +10 SET ARY="^TMP($J,""FORM BLOCKS"")"
- +11 KILL @ARY
- +12 ;FORM,EXCLUDE,ARY are inputs to FINDALL
- SET CNT=$$FINDALL
- +13 ;
- +14 ;if CNT=1 return the only block
- +15 IF CNT=1
- SET NAME=$ORDER(@ARY@("NAME",""))
- QUIT $SELECT(NAME'="":$ORDER(@ARY@("NAME",NAME,0)),1:"")
- +16 ;
- +17 ;if CNT'=1 loop through the blocks, displaying them to the user and let him choose
- AGAIN ;
- +1 SET (PICK,NAME)=""
- SET COUNT=0
- +2 FOR
- SET NAME=$ORDER(@ARY@("NAME",NAME))
- IF (PICK'="")!(NAME="")
- QUIT
- Begin DoDot:1
- +3 SET BLK=0
- FOR
- SET BLK=$ORDER(@ARY@("NAME",NAME,BLK))
- IF (PICK'="")!('BLK)
- QUIT
- Begin DoDot:2
- +4 SET COUNT=COUNT+1
- SET @ARY@("#",COUNT)=BLK
- WRITE !,COUNT," ",NAME,?38,$EXTRACT($PIECE($GET(^IBE(357.1,BLK,0)),"^",13),1,42)
- +5 IF COUNT#SCRNSIZE=0
- SET PICK=$$CHOOSE
- End DoDot:2
- IF NAME=""
- QUIT
- End DoDot:1
- +6 IF (PICK="")
- IF COUNT
- IF COUNT#SCRNSIZE'=0
- SET PICK=$$CHOOSE
- +7 IF PICK=""
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="No block selected! Try again"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- IF '$DATA(DIRUT)
- IF Y=1
- GOTO AGAIN
- +8 IF PICK="?"
- GOTO AGAIN
- +9 KILL @ARY
- +10 QUIT $SELECT((PICK'>0):"",1:PICK)
- +11 ;
- FINDALL() ;finds all of the blocks on FORM (except the one named EXCLUDE) and puts them on @ARY,returns the cound
- +1 NEW BLK,COUNT,NODE
- +2 SET BLK=""
- SET COUNT=0
- FOR
- SET BLK=$ORDER(^IBE(357.1,"C",FORM,BLK))
- IF 'BLK
- QUIT
- SET NODE=$GET(^IBE(357.1,BLK,0))
- SET NAME=$PIECE(NODE,"^")
- IF (NAME'="")&(NAME'=EXCLUDE)&($PIECE(NODE,"^",2)=FORM)
- SET @ARY@("NAME",$$UP^XLFSTR(NAME),BLK)=""
- SET COUNT=COUNT+1
- +3 QUIT COUNT
- +4 ;
- CHOOSE() ;asks the user to select a blk - @ARY@("#", is the aray of blocks displayed so far(subscripted by the number on the list), @ARY@("NAME", the entire array (subscripted by name,ien)
- +1 ;sets NAME to " " and COUNT to 0 if ? is entered - starts display of list over
- +2 NEW ANS,QUIT,PICK,NEXT1,NEXT2
- +3 SET QUIT=0
- +4 FOR
- IF QUIT
- QUIT
- Begin DoDot:1
- +5 SET (PICK,ANS)=""
- +6 WRITE !,"Choose 1-",COUNT,$SELECT(COUNT<CNT:" or hit RETURN to see more",1:""),": "
- +7 READ ANS:DTIME
- +8 IF '$TEST!($EXTRACT(ANS,1)="^")
- SET PICK=-1
- SET QUIT=1
- QUIT
- +9 IF ANS=""
- SET QUIT=1
- QUIT
- +10 IF $EXTRACT(ANS,1)="?"
- DO HELP
- QUIT
- +11 ;
- +12 ;convert to upper case
- +13 SET ANS=$$UP^XLFSTR(ANS)
- +14 +15 ;if user entered a displayed number then he's made his choice
- +16 IF $DATA(@ARY@("#",ANS))
- SET PICK=$GET(@ARY@("#",ANS))
- SET QUIT=1
- QUIT
- +17 ;
- +18 ;if the user entered an exact name, and the name is unique then he's made his choice
- +19 SET PICK=$ORDER(@ARY@("NAME",ANS,PICK))
- IF PICK
- IF '$ORDER(@ARY@("NAME",ANS,PICK))
- SET QUIT=1
- QUIT
- +20 ;don't set QUIT=1 because name is not unique
- IF PICK
- QUIT
- +21 ;
- +22 ;if the user entered a partial name accept it if there is exactly one match
- +23 SET NEXT1=$ORDER(@ARY@("NAME",ANS))
- IF (NEXT1="")!($EXTRACT(NEXT1,1,$LENGTH(ANS))'=ANS)
- QUIT
- +24 ;because user did not type in enough to uniquely identify the block
- SET NEXT2=$ORDER(@ARY@("NAME",NEXT1))
- IF ($EXTRACT(NEXT2,1,$LENGTH(ANS))=ANS)
- QUIT
- +25 ;make sure there are not two blocks with the same name - if ok, accept it
- +26 SET PICK=$ORDER(@ARY@("NAME",NEXT1,PICK))
- IF 'PICK
- QUIT
- IF '$ORDER(@ARY@("NAME",NEXT1,PICK))
- SET QUIT=1
- QUIT
- End DoDot:1
- IF 'QUIT
- DO MSG
- +27 QUIT PICK
- +28 ;
- HELP ;choosing help restarts the display (by setting NAME="")
- +1 WRITE !,"You can choose a block by the number or by it's name.",!
- +2 DO PAUSE^IBDFU5
- +3 SET QUIT=1
- SET NAME=""
- SET PICK="?"
- SET COUNT=0
- +4 QUIT
- MSG ;
- +1 WRITE !,"You must enter the number or name of the block!"
- +2 DO PAUSE^IBDFU5
- +3 QUIT