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