- 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 Feb 19, 2025@00:18:02 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