- IBDE3 ;ALB/CJM - ENCOUNTER FORM - IMP/EXP UTILITY -DISPLAYS TOOLKIT BLOCKS ;AUG 12,1993
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
- ;
- HDR ;
- S VALMHDR(1)="LIST OF TOOLKIT BLOCKS READY FOR IMPORT OR EXPORT"
- S VALMHDR(3)="(** there are "_$S($O(^IBE(358,0)):"also",1:"no")_" forms in the work space **)"
- Q
- ONENTRY ;
- N LINE
- S VALMCNT=$G(BLKCNT)
- I $D(BLKLIST) S LINE=0 F S LINE=$O(@BLKLIST@(LINE)) Q:'LINE D FLDCTRL^VALM10(LINE)
- Q
- ONEXIT ;
- Q
- ;
- IDXBLKS ;build an array of forms used by IBCLINIC for the list processor
- N BLOCK,NODE,ORDER
- K @BLKLIST
- S (VALMCNT,ORDER)=0 F S ORDER=$O(^IBE(358.1,"D",ORDER)) Q:'ORDER S BLOCK=0 F S BLOCK=$O(^IBE(358.1,"D",ORDER,BLOCK)) Q:'BLOCK D
- .I $D(^IBE(358.1,BLOCK,0)) D
- ..S VALMCNT=VALMCNT+1,@BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT),@BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK D FLDCTRL^VALM10(VALMCNT) ;set video for ID column
- S BLKCNT=VALMCNT
- Q
- ;
- DISPLAY(BLOCK,ID) ;
- N NODE,RET
- S RET=$J(ID,3)_" "
- S NODE=$G(^IBE(358.1,BLOCK,0))
- S RET=RET_$$PADRIGHT^IBDFU($P(NODE,"^",1),30)_" "_$P(NODE,"^",13)
- Q RET
- ;
- ADD ;adds a block to the work space
- N OLDBLOCK,NEWBLOCK
- D FULL^VALM1
- S VALMBCK="R"
- S OLDBLOCK=$$SELECT Q:'OLDBLOCK
- S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,"",357.1,358.1,"","",1)
- I NEWBLOCK K DIE,DR,DA S DIE="^IBE(358.1,",DA=NEWBLOCK,DR="1;" D ^DIE K DIE,DR,DA
- D IDXBLKS
- Q
- ;
- DELETE ;deletes a block from the work space
- N PICK,FORM,IBTKBLK
- S IBTKBLK=1 ;can't delete tk blocks unless IBTKBLK
- D EN^VALM2($G(XQORNOD(0)))
- S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) I BLOCK,$$RUSURE^IBDFU5($P($G(^IBE(358.1,BLOCK,0)),"^")) D DLTBLK^IBDFU3(BLOCK,"",358.1)
- S VALMBCK="R"
- D IDXBLKS
- Q
- EDIT ;allows the export notes of a block to be edited
- N PICK,BLOCK
- D EN^VALM2($G(XQORNOD(0)))
- D FULL^VALM1
- S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D:BLOCK
- .K DIE,DR,DA S DIE="^IBE(358.1,",DR="1;",DA=BLOCK D ^DIE K DIE,DA,DR
- S VALMBCK="R"
- D IDXBLKS
- Q
- IMPORT ;allows the user to pick a block from the imp/exp files, then import it
- N PICK,BLOCK,NEWBLOCK,IBTKBLK,NAME
- S IBTKBLK=1
- D EN^VALM2($G(XQORNOD(0)))
- D FULL^VALM1
- S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D:BLOCK
- .S NAME=$$NEWNAME($P($G(^IBE(358.1,BLOCK,0)),"^"))
- .Q:NAME=""
- .S NEWBLOCK=$$COPYBLK^IBDFU2(BLOCK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13,NAME)
- .D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLOCK,"",358.1)
- S VALMBCK="R"
- D IDXBLKS
- D UPDATE^IBDECLN(1) ;clean up qualifiers (with messages)
- Q
- VIEW ;allows the export notes of a form to be edited
- N PICK,BLOCK,IBARY,IBHDRRTN
- D EN^VALM2($G(XQORNOD(0)),"S")
- S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S BLOCK=+$G(@VALMAR@("IDX",PICK,PICK)) D
- .S IBHDRRTN="D VIEWHDR^IBDE3"
- .S IBARY="^IBE(358.1,"_BLOCK_",1)"
- .D EN^VALM("IBDE TEXT DISPLAY")
- S VALMBCK="R"
- Q
- VIEWHDR ;
- S VALMHDR(1)="Export Notes For "_$P($G(^IBE(358.1,BLOCK,0)),"^")_" Block"
- Q
- SELECT() ;allows the user to select a form, then a block from it
- N IBFORM,IBBLK
- S (IBFORM,IBBLK)=""
- K DIR S DIR(0)="S^1:TOOLKIT BLOCK;2:BLOCK FROM A TOOLKIT FORM;3:BLOCK FROM A FORM NOT IN THE TOOLKIT"
- S DIR("A")="What type of block do you want to export?"
- D ^DIR K DIR
- Q:(Y=-1)!($D(DIRUT)) ""
- I Y=1 D
- .S IBFORM=$$TKFORM^IBDFU2C
- E S IBFORM=$$SLCTFORM^IBDFU4($S(Y=2:1,1:0))
- I IBFORM D
- .W !!,"NOW CHOOSE THE BLOCK TO COPY!",!
- .S IBBLK=$$SLCTBLK^IBDFU8(IBFORM)
- Q IBBLK
- ;
- NEWNAME(OLDNAME) ;asks the user to select uniqued toolkit block name
- ;returns "" if unsuccessfull, else the blk name
- ;shows OLDNAME as the default if defined
- ;
- N NAME,FOUND,TKBLK,ORDER S NAME=""
- K DIR S DIR(0)="357.1,.01A",DIR("A")="New Toolkit Block Name: ",DIR("?")="Enter a unique name for the toolkit block up to 30 characters"
- S DIR("B")="" I $G(OLDNAME)'="" S DIR("B")=OLDNAME
- F D Q:'FOUND
- .S FOUND=0
- .D ^DIR I $D(DIRUT) S Y="" Q
- .S ORDER=0 F S ORDER=$O(^IBE(357.1,"D",ORDER)) Q:ORDER="" S TKBLK=$O(^IBE(357.1,"D",ORDER,0)) Q:'TKBLK I $P($G(^IBE(357.1,TKBLK,0)),"^")=Y W !,"There is already a toolkit block with that name! The name should be unique." S FOUND=1 Q
- S:'FOUND NAME=Y
- K DIR
- Q NAME
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDE3 4283 printed Jan 18, 2025@02:40:04 Page 2
- IBDE3 ;ALB/CJM - ENCOUNTER FORM - IMP/EXP UTILITY -DISPLAYS TOOLKIT BLOCKS ;AUG 12,1993
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
- +2 ;
- HDR ;
- +1 SET VALMHDR(1)="LIST OF TOOLKIT BLOCKS READY FOR IMPORT OR EXPORT"
- +2 SET VALMHDR(3)="(** there are "_$SELECT($ORDER(^IBE(358,0)):"also",1:"no")_" forms in the work space **)"
- +3 QUIT
- ONENTRY ;
- +1 NEW LINE
- +2 SET VALMCNT=$GET(BLKCNT)
- +3 IF $DATA(BLKLIST)
- SET LINE=0
- FOR
- SET LINE=$ORDER(@BLKLIST@(LINE))
- if 'LINE
- QUIT
- DO FLDCTRL^VALM10(LINE)
- +4 QUIT
- ONEXIT ;
- +1 QUIT
- +2 ;
- IDXBLKS ;build an array of forms used by IBCLINIC for the list processor
- +1 NEW BLOCK,NODE,ORDER
- +2 KILL @BLKLIST
- +3 SET (VALMCNT,ORDER)=0
- FOR
- SET ORDER=$ORDER(^IBE(358.1,"D",ORDER))
- if 'ORDER
- QUIT
- SET BLOCK=0
- FOR
- SET BLOCK=$ORDER(^IBE(358.1,"D",ORDER,BLOCK))
- if 'BLOCK
- QUIT
- Begin DoDot:1
- +4 IF $DATA(^IBE(358.1,BLOCK,0))
- Begin DoDot:2
- +5 ;set video for ID column
- SET VALMCNT=VALMCNT+1
- SET @BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT)
- SET @BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK
- DO FLDCTRL^VALM10(VALMCNT)
- End DoDot:2
- End DoDot:1
- +6 SET BLKCNT=VALMCNT
- +7 QUIT
- +8 ;
- DISPLAY(BLOCK,ID) ;
- +1 NEW NODE,RET
- +2 SET RET=$JUSTIFY(ID,3)_" "
- +3 SET NODE=$GET(^IBE(358.1,BLOCK,0))
- +4 SET RET=RET_$$PADRIGHT^IBDFU($PIECE(NODE,"^",1),30)_" "_$PIECE(NODE,"^",13)
- +5 QUIT RET
- +6 ;
- ADD ;adds a block to the work space
- +1 NEW OLDBLOCK,NEWBLOCK
- +2 DO FULL^VALM1
- +3 SET VALMBCK="R"
- +4 SET OLDBLOCK=$$SELECT
- if 'OLDBLOCK
- QUIT
- +5 SET NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,"",357.1,358.1,"","",1)
- +6 IF NEWBLOCK
- KILL DIE,DR,DA
- SET DIE="^IBE(358.1,"
- SET DA=NEWBLOCK
- SET DR="1;"
- DO ^DIE
- KILL DIE,DR,DA
- +7 DO IDXBLKS
- +8 QUIT
- +9 ;
- DELETE ;deletes a block from the work space
- +1 NEW PICK,FORM,IBTKBLK
- +2 ;can't delete tk blocks unless IBTKBLK
- SET IBTKBLK=1
- +3 DO EN^VALM2($GET(XQORNOD(0)))
- +4 SET PICK=""
- FOR
- SET PICK=$ORDER(VALMY(PICK))
- if 'PICK
- QUIT
- SET BLOCK=+$GET(@VALMAR@("IDX",PICK,PICK))
- IF BLOCK
- IF $$RUSURE^IBDFU5($PIECE($GET(^IBE(358.1,BLOCK,0)),"^"))
- DO DLTBLK^IBDFU3(BLOCK,"",358.1)
- +5 SET VALMBCK="R"
- +6 DO IDXBLKS
- +7 QUIT
- EDIT ;allows the export notes of a block to be edited
- +1 NEW PICK,BLOCK
- +2 DO EN^VALM2($GET(XQORNOD(0)))
- +3 DO FULL^VALM1
- +4 SET PICK=""
- FOR
- SET PICK=$ORDER(VALMY(PICK))
- if 'PICK
- QUIT
- SET BLOCK=+$GET(@VALMAR@("IDX",PICK,PICK))
- if BLOCK
- Begin DoDot:1
- +5 KILL DIE,DR,DA
- SET DIE="^IBE(358.1,"
- SET DR="1;"
- SET DA=BLOCK
- DO ^DIE
- KILL DIE,DA,DR
- End DoDot:1
- +6 SET VALMBCK="R"
- +7 DO IDXBLKS
- +8 QUIT
- IMPORT ;allows the user to pick a block from the imp/exp files, then import it
- +1 NEW PICK,BLOCK,NEWBLOCK,IBTKBLK,NAME
- +2 SET IBTKBLK=1
- +3 DO EN^VALM2($GET(XQORNOD(0)))
- +4 DO FULL^VALM1
- +5 SET PICK=""
- FOR
- SET PICK=$ORDER(VALMY(PICK))
- if 'PICK
- QUIT
- SET BLOCK=+$GET(@VALMAR@("IDX",PICK,PICK))
- if BLOCK
- Begin DoDot:1
- +6 SET NAME=$$NEWNAME($PIECE($GET(^IBE(358.1,BLOCK,0)),"^"))
- +7 if NAME=""
- QUIT
- +8 SET NEWBLOCK=$$COPYBLK^IBDFU2(BLOCK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13,NAME)
- +9 if $GET(NEWBLOCK)
- DO DLTBLK^IBDFU3(BLOCK,"",358.1)
- End DoDot:1
- +10 SET VALMBCK="R"
- +11 DO IDXBLKS
- +12 ;clean up qualifiers (with messages)
- DO UPDATE^IBDECLN(1)
- +13 QUIT
- VIEW ;allows the export notes of a form to be edited
- +1 NEW PICK,BLOCK,IBARY,IBHDRRTN
- +2 DO EN^VALM2($GET(XQORNOD(0)),"S")
- +3 SET PICK=""
- FOR
- SET PICK=$ORDER(VALMY(PICK))
- if 'PICK
- QUIT
- SET BLOCK=+$GET(@VALMAR@("IDX",PICK,PICK))
- Begin DoDot:1
- +4 SET IBHDRRTN="D VIEWHDR^IBDE3"
- +5 SET IBARY="^IBE(358.1,"_BLOCK_",1)"
- +6 DO EN^VALM("IBDE TEXT DISPLAY")
- End DoDot:1
- +7 SET VALMBCK="R"
- +8 QUIT
- VIEWHDR ;
- +1 SET VALMHDR(1)="Export Notes For "_$PIECE($GET(^IBE(358.1,BLOCK,0)),"^")_" Block"
- +2 QUIT
- SELECT() ;allows the user to select a form, then a block from it
- +1 NEW IBFORM,IBBLK
- +2 SET (IBFORM,IBBLK)=""
- +3 KILL DIR
- SET DIR(0)="S^1:TOOLKIT BLOCK;2:BLOCK FROM A TOOLKIT FORM;3:BLOCK FROM A FORM NOT IN THE TOOLKIT"
- +4 SET DIR("A")="What type of block do you want to export?"
- +5 DO ^DIR
- KILL DIR
- +6 if (Y=-1)!($DATA(DIRUT))
- QUIT ""
- +7 IF Y=1
- Begin DoDot:1
- +8 SET IBFORM=$$TKFORM^IBDFU2C
- End DoDot:1
- +9 IF '$TEST
- SET IBFORM=$$SLCTFORM^IBDFU4($SELECT(Y=2:1,1:0))
- +10 IF IBFORM
- Begin DoDot:1
- +11 WRITE !!,"NOW CHOOSE THE BLOCK TO COPY!",!
- +12 SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM)
- End DoDot:1
- +13 QUIT IBBLK
- +14 ;
- NEWNAME(OLDNAME) ;asks the user to select uniqued toolkit block name
- +1 ;returns "" if unsuccessfull, else the blk name
- +2 ;shows OLDNAME as the default if defined
- +3 ;
- +4 NEW NAME,FOUND,TKBLK,ORDER
- SET NAME=""
- +5 KILL DIR
- SET DIR(0)="357.1,.01A"
- SET DIR("A")="New Toolkit Block Name: "
- SET DIR("?")="Enter a unique name for the toolkit block up to 30 characters"
- +6 SET DIR("B")=""
- IF $GET(OLDNAME)'=""
- SET DIR("B")=OLDNAME
- +7 FOR
- Begin DoDot:1
- +8 SET FOUND=0
- +9 DO ^DIR
- IF $DATA(DIRUT)
- SET Y=""
- QUIT
- +10 SET ORDER=0
- FOR
- SET ORDER=$ORDER(^IBE(357.1,"D",ORDER))
- if ORDER=""
- QUIT
- SET TKBLK=$ORDER(^IBE(357.1,"D",ORDER,0))
- if 'TKBLK
- QUIT
- IF $PIECE($GET(^IBE(357.1,TKBLK,0)),"^")=Y
- WRITE !,"There is already a toolkit block with that name! The name should be unique."
- SET FOUND=1
- QUIT
- End DoDot:1
- if 'FOUND
- QUIT
- +11 if 'FOUND
- SET NAME=Y
- +12 KILL DIR
- +13 QUIT NAME