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

IBDF7.m

Go to the documentation of this file.
  1. IBDF7 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(ADDING TOOLKIT BLKS) ;01/08/93
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
  1. ;
  1. ;
  1. ADD ;create a new block by copying a toolkit block
  1. N BLKLIST,OLDBLOCK,NEWBLOCK,TOP,BOT,IBBG,IBLFT,IBDLST,IBDCS,IBDX,IBDY
  1. S VALMBCK="R",IBBG=+$G(VALMBG),OLDBLOCK="",IBLFT=+$G(VALMLFT)
  1. D EN^VALM("IBDF TOOL KIT BLOCK LIST") ;list processor displays list of tool kit blocks
  1. I '$G(IBFASTXT) D
  1. .S VALMBG=IBBG S:VALMBG<1 VALMBG=1
  1. .Q:OLDBLOCK="" ;selected tool kit block stored in OLDBLOCK
  1. .S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,IBFORM,357.1,357.1,IBBG-1,IBLFT-5,0,"",1)
  1. .D RE^VALM4,POS^IBDFU4(NEWBLOCK)
  1. .S VALMBCK="R"
  1. .D TOPNBOT^IBDFU5(NEWBLOCK,.TOP,.BOT)
  1. .D IDXFORM^IBDF5A(TOP,BOT)
  1. .;Now check if new block contains any selection lists that specify ICD-9 or ICD-10
  1. .;if so, update history field at #357 .19 or .2 plus field .21
  1. .S IBDLST=0 F S IBDLST=$O(^IBE(357.2,"C",NEWBLOCK,IBDLST)) Q:IBDLST="" S IBDX=$P(^IBE(357.2,IBDLST,0),U,11) D:IBDX?1.N
  1. ..S IBDCS=$P(^IBE(357.6,IBDX,0),U,22) D:IBDCS=1!(IBDCS=30) ;Coding System 1=ICD-9 30=ICD-10
  1. ...I '$O(^IBE(357.3,"C",IBDLST,"")) Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
  1. ...S IBDY=$$CSUPD357^IBDUTICD(IBFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
  1. Q
  1. ;
  1. INIT ;entry code to list
  1. S BLKLIST="^TMP(""IBDF"",$J,""TOOL KIT BLOCK LIST"")"
  1. D IDXBLKS
  1. Q
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K @BLKLIST
  1. Q
  1. ;
  1. IDXBLKS ; sets up list of toolkit blocks for list processor
  1. N BLOCK,TK
  1. K @BLKLIST
  1. S VALMCNT=0
  1. S TK=0,BLOCK="" F S TK=$O(^IBE(357.1,"D",TK)) Q:'TK F S BLOCK=$O(^IBE(357.1,"D",TK,BLOCK)) Q:'BLOCK D
  1. .Q:'$P($G(^IBE(357.1,BLOCK,0)),"^",14)
  1. .S VALMCNT=VALMCNT+1
  1. .S @BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT,TK),@BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK
  1. .D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column
  1. Q
  1. ;
  1. DISPLAY(BLOCK,ID,TKORDER) ;adds one toolkit block to the list array
  1. N NODE,NAME,DESCR,RET
  1. ;** note: IBTKBLK=1 only if editing the tool kit blocks - display the tool kit order in that case
  1. S RET=$J(ID,3)_$$PADRIGHT^IBDFU("",2)
  1. S NODE=$G(^IBE(357.1,BLOCK,0))
  1. S NAME=$P(NODE,"^",1),DESCR=$P(NODE,"^",13)
  1. S RET=RET_$$PADRIGHT^IBDFU(NAME,30)_" "
  1. I $G(IBTKBLK) S RET=RET_$E($J(TKORDER,4),1,4)_" "
  1. S RET=RET_$E(DESCR,1,80)
  1. Q RET
  1. SELECT ;
  1. N CHOICE
  1. D EN^VALM2($G(XQORNOD(0)),"S")
  1. S CHOICE=$O(VALMY("")) Q:'CHOICE S OLDBLOCK=$G(@VALMAR@("IDX",CHOICE,CHOICE))
  1. Q