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

IBDF9B4.m

Go to the documentation of this file. 
  1. IBDF9B4 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add Hand Print fields) ;JUL 20,1994
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1.  ;
  1. HFIELD ;Create, Edit, or Delete a Hand Print field from the form
  1.  ;
  1.  N IBVALMBG,QUIT
  1.  S IBVALMBG=VALMBG
  1.  S QUIT=0
  1.  S VALMBCK="R"
  1.  ;
  1.  F  D  Q:QUIT
  1.  .D FULL^VALM1
  1.  .K DIR S DIR("?",1)="You can Create, Edit, or Delete an hand print field, or Shift all of the hand print fields",DIR("?")="within a definable range either up or down."
  1.  .W !!,DIR("?",1),!,DIR("?"),!
  1.  .S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit",DIR("A")="[C]reate,   [D]elete,   [E]dit,   [S]hift,   [Q]uit"
  1.  .D ^DIR K DIR I $D(DIRUT)!(Y<0) S QUIT=1 Q
  1.  .I Y="Q" S QUIT=1 Q
  1.  .D @$S(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
  1.  .D RE^VALM4
  1.  S VALMBCK="R",VALMBG=IBVALMBG
  1.  Q
  1. SHIFT ;expects IBBLK to be defined - shifts all hand print fields within range supplied by user
  1.  D SHIFT^IBDF10("H")
  1.  D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
  1.  Q
  1. EDITFLD ;expects IBBLK to be defined
  1.  N IBFIELD,RTN,NODE
  1.  N IBOLD,IBDELETE,IBX,IBY,IBLEN,IBTYPE ;these are used in the input template
  1.  D SELECT
  1.  I IBFIELD D
  1.  .D RE^VALM4
  1.  .S (IBX,IBY,IBLEN)=0
  1.  .S IBOLD=1,IBTYPE=$P($G(^IBE(359.94,IBFIELD,0)),"^",5)
  1.  .K DR,DIE,DA S DIE=359.94,DA=IBFIELD,DR="[IBDF EDIT HAND PRINT FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
  1.  .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
  1.  Q
  1. SELECT ;
  1.  S IBFIELD=0
  1.  Q:'$G(IBBLK)
  1.  I '$O(^IBE(359.94,"C",IBBLK,0)) W !,"There is no hand print field!" D PAUSE^IBDFU5 Q
  1. AGAIN K DIC S DIC="^IBE(359.94,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
  1.  S DIC("S")="I $P($G(^(0)),U,8)=IBBLK"
  1.  D IX^DIC K DIC
  1.  S:+Y>0 IBFIELD=+Y
  1.  I 'IBFIELD,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No hand print field selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
  1.  Q
  1. DLTFLD ;expects IBBLK to be defined
  1.  N IBFIELD
  1.  D SELECT
  1.  I IBFIELD D
  1.  .Q:'$$RUSURE^IBDFU5($P($G(^IBE(359.94,IBFIELD,0)),"^"))
  1.  .D DLTHFLD^IBDFU3(359.94,IBBLK,IBFIELD)
  1.  .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
  1.  Q
  1. NEWFLD ;adds a new field, expects IBBLK to be defined
  1.  N NAME,FIELD,NODE,IBRTN,DLAYGO
  1.  N IBX,IBY,IBLEN,IBDELETE,IBOLD,IBTYPE ;these are used in the input template
  1.  S NAME=$$NEWNAME^IBDF9B Q:NAME=-1
  1.  S IBOLD=0,(IBX,IBY,IBLEN)=""
  1.  K DIC,DIE,DD,DO,DINUM S DIC="^IBE(359.94,",DIC(0)="FL",X=NAME,DLAYGO=359.94
  1.  D FILE^DICN K DIC,DIE,DA
  1.  S FIELD=$S(+Y<0:"",1:+Y)
  1.  I 'FIELD D
  1.  .W !,"Unable to create a new hand print field!" D PAUSE^IBDFU5
  1.  I FIELD D
  1.  .S IBDELETE=1
  1.  .K DIE,DA,DR S DIE=359.94,DA=FIELD,DR="[IBDF EDIT HAND PRINT FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
  1.  .I IBDELETE K DA S DIK="^IBE(359.94,",DA=FIELD D ^DIK K DIK,DA Q
  1.  .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
  1.  Q
  1.  ;
  1. LENGTHDT(TYPE) ;
  1.  Q:'$G(TYPE) 0
  1.  N NODE,LEN
  1.  S NODE=$G(^IBE(359.1,TYPE,0))
  1.  S LEN=$L($P(NODE,"^",11))
  1.  S:LEN LEN=LEN+1
  1.  S LEN=LEN+(4*$P(NODE,"^",6))
  1.  Q LEN