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

IBDF9A1.m

Go to the documentation of this file. 
  1. IBDF9A1 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;FEB 1,1993
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1.  ;
  1. NEWLIST ;creates a new list
  1.  ;expects IBBLK to be defined
  1.  N IBLIST,IBLEN,IBP,IBRTN,NAME,IBDELETE,IBDYN,IBINPUT,IBDFLTF,IBDFLTB,IBDFLTL
  1.  S (IBDFLTF,IBDFLTB,IBDFLTL,IBOLD,IBLIST)=0,VALMBCK="R"
  1.  D FULL^VALM1
  1.  S IBRTN=$$RTN^IBDF9A Q:'IBRTN
  1.  S IBDFLTF=$$DFLTS^IBDFU5 D:IBDFLTF
  1.  .S IBDFLTB=0 F  S IBDFLTB=$O(^IBE(357.1,"C",IBDFLTF,IBDFLTB)) Q:'IBDFLTB  D  Q:IBDFLTL
  1.  ..S IBDFLTL=0 F  S IBDFLTL=$O(^IBE(357.2,"C",IBDFLTB,IBDFLTL)) Q:'IBDFLTL  Q:$P($G(^IBE(357.2,IBDFLTL,0)),"^",11)=IBRTN
  1.  I IBDFLTL D  Q:IBLIST
  1.  .S IBLIST=$$COPYLIST^IBDFU2(IBDFLTL,IBDFLTB,IBBLK,357.2,357.2)
  1.  .Q:'IBLIST
  1.  .K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF POSITION/SIZE COLUMNS]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
  1.  .S VALMBCK="R" D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
  1.  S NAME=$$NEWNAME^IBDF9A Q:NAME=-1
  1.  K DIC,DIE,DD,DO,DINUM,DA
  1.  N DLAYGO
  1.  S DIC="^IBE(357.2,",DIC(0)="FL",X=NAME,DLAYGO=357.2
  1.  D FILE^DICN K DIC,DA
  1.  S IBLIST=$S(+Y<0:"",1:+Y)
  1.  I 'IBLIST D
  1.  .W !,"Unable to create a new selection list!" D PAUSE^IBDFU5
  1.  I IBLIST D
  1.  .D DLISTCNT^IBDFU3(IBLIST,357.2) ;deletes anything that may have been left lying around that now points to IBLIST
  1.  .K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF EDIT SELECTION LIST]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
  1.  .I IBDELETE K DA S DIK="^IBE(357.2,",DA=IBLIST D ^DIK K DIK,DA
  1.  .I IBLIST,'IBDELETE D ADDGROUP("BLANK",0)
  1.  .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
  1.  S VALMBCK="R"
  1.  Q
  1. ADDGROUP(NAME,ORDER) ;adds a group to the selection list=IBLIST
  1.  N GROUP
  1.  K DIC,DIE,DD,DO,DINUM,DA
  1.  N DLAYGO
  1.  S DIC="^IBE(357.4,",DIC(0)="FL",X=NAME,DLAYGO=357.4
  1.  D FILE^DICN K DIC,DA
  1.  S GROUP=$S(+Y<0:"",1:+Y)
  1.  I GROUP D
  1.  .S NODE=$G(^IBE(357.4,GROUP,0)) S $P(NODE,"^",2)=ORDER,$P(NODE,"^",3)=IBLIST S ^IBE(357.4,GROUP,0)=NODE
  1.  .S DIK="^IBE(357.4,",DA=GROUP D IX1^DIK K DIK,DA
  1.  Q
  1.  ;
  1. FORMAT ;allows the user to format all of the selections on the list in mass
  1.  ;
  1.  ;
  1.  ;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
  1.  ;SUBCOL is the subcolumn to format
  1.  ;
  1.  N TYPE,SUBCOL,SLCTN
  1.  ;
  1.  ;ask for the subcolumn to format
  1.  S SUBCOL=$$SUBCOL
  1.  ;
  1.  ;ask for the type of fomatting
  1.  S TYPE=$S(SUBCOL:$$TYPE,1:"")
  1.  ;
  1.  ;find all the sections to be formatted and do so
  1.  I TYPE'="",SUBCOL S SLCTN=0 F  S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN  D:$P($G(^IBE(357.3,SLCTN,0)),"^",3)=IBLIST CHANGE(SLCTN,SUBCOL,TYPE)
  1.  ;
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. FORMAT2 ;allows the user to format all of the selections in the group in mass
  1.  ;
  1.  ;
  1.  ;TYPE = type of formating - U=upper case,L=lower case,C=capitalize
  1.  ;SUBCOL is the subcolumn to format
  1.  ;
  1.  N TYPE,SUBCOL,SLCTN
  1.  ;
  1.  ;ask for the subcolumn to format
  1.  S SUBCOL=$$SUBCOL
  1.  ;
  1.  ;ask forthe type of fomatting
  1.  S TYPE=$S(SUBCOL:$$TYPE,1:"")
  1.  ;
  1.  ;find all the sections to be formatted and do so
  1.  I TYPE'="",SUBCOL S SLCTN=0 F  S SLCTN=$O(^IBE(357.3,"D",IBGRP,SLCTN)) Q:'SLCTN  D:$P($G(^IBE(357.3,SLCTN,0)),"^",4)=IBGRP CHANGE(SLCTN,SUBCOL,TYPE)
  1.  ;
  1.  D IDXSLCTN^IBDF4
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. TYPE() ;ask the user what type of formatting
  1.  N TYPE S TYPE=""
  1.  K DIR S DIR(0)="SOB^UPPERCASE:U;LOWERCASE:L;CAPITALIZE:C"
  1.  S DIR("A")="Select the type of formatting",DIR("B")="C"
  1.  D ^DIR K DIR
  1.  I '$D(DIRUT),Y'=-1 S TYPE=Y
  1.  Q $E(TYPE,1)
  1.  ;
  1. CHANGE(SLCTN,SUBCOL,TYPE) ;
  1.  ;
  1.  N DA,NODE,STR
  1.  S DA=$O(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
  1.  Q:'DA
  1.  S NODE=$G(^IBE(357.3,SLCTN,1,DA,0))
  1.  S STR=$P(NODE,"^",2)
  1.  D:$L(STR)
  1.  .I TYPE="U" S STR=$$UP^XLFSTR(STR)
  1.  .I TYPE="L" S STR=$$LOW^XLFSTR(STR)
  1.  .I TYPE="C" S STR=$$CAPS(STR)
  1.  .S $P(^IBE(357.3,SLCTN,1,DA,0),"^",2)=STR
  1.  Q
  1.  ;
  1. CAPS(STR) ;returns STR with each word in it capitalized
  1.  N FIRST,I,CHAR,LEN
  1.  S FIRST=1,LEN=$L(STR)
  1.  F I=1:1 S CHAR=$E(STR,I) Q:CHAR=""  D
  1.  .I CHAR?1A,FIRST D
  1.  ..S FIRST=0,CHAR=$$UP^XLFSTR(CHAR)
  1.  .E  I CHAR?1A D
  1.  ..S CHAR=$$LOW^XLFSTR(CHAR)
  1.  .E  S FIRST=1
  1.  .S STR=$E(STR,1,I-1)_CHAR_$E(STR,I+1,LEN)
  1.  Q STR
  1.  ;
  1. SUBCOL() ;ask what subcolumn to format
  1.  ;SCLIST - used to record the subcolumns that can be formated - each digit will signify a subcolum
  1.  ;
  1.  N SCLIST,NODE,SUBCOL,ANS
  1.  ;first get the list of subcolumns that can be formatted
  1.  S SCLIST="",SUBCOL=0
  1.  F  S SUBCOL=$O(IBLIST("SCTYPE",SUBCOL)) Q:'SUBCOL  I $G(IBLIST("SCW",SUBCOL)),IBLIST("SCTYPE",SUBCOL)=1,IBLIST("SCEDITABLE",SUBCOL) S SCLIST=SCLIST_","_SUBCOL
  1.  ;if there is at most one subcolumn that can be edited return that
  1.  I $L(SCLIST)<3 Q $E(SCLIST,2)
  1.  ;
  1.  ;now ask what subcolumn to format
  1. AGAIN W !,"What subcolumn do you want formated? Choose from (",$E(SCLIST,2,10),"): "
  1.  R ANS:DTIME
  1.  I '$T!(ANS["^") Q ""
  1.  I ANS?1N,SCLIST[ANS Q ANS
  1.  G AGAIN
  1.  Q ANS