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 Dec 13, 2024@01:38:50 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
