- IBDF13 ;ALB/CJM - ENCOUNTER FORM - EDITING TOOLKIT BLKS ; 24-JUN-1993
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- LIST ;displays list of toolkit blocks, then allows editng
- N IBFORM,IBTKFORM,IBTKBLK,IBFASTXT,IOVL,IOHL,IOBRC,IOBLC,IOTRC,IOTLC,IBBLK,BLKLIST,D0,DA,IBDEVICE
- S (IBTKFORM,IBFASTXT,IBBLK)=0,IBTKBLK=1
- S IBFORM("NAME")="LIST OF TOOLKIT BLOCKS",IBFORM("TOOLKIT")=1,IBFORM("COMPILED")=0,IBFORM("HT")=80,IBFORM("WIDTH")=133,IBFORM("PAGE_HT")=80,IBFORM("PAGES")=1,IBFORM("SCAN")=1,IBFORM("SCAN","ICR")=1,IBFORM("SCAN",1)=1
- ;
- D DEVICE^IBDFUA(1,.IBDEVICE)
- K XQORS,VALMEVL
- D PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,0)
- S IBFORM=$$TKFORM^IBDFU2C
- D EN^VALM("IBDF EDIT TOOL KIT BLOCKS") ;list processor displays list of toolkit blocks
- Q
- ;
- SELECT() ;allows the user to select from the displayed list of TK blocks
- N CHOICE,IBBLK
- S IBBLK=""
- D EN^VALM2($G(XQORNOD(0)),"S")
- S CHOICE=$O(VALMY("")) S:CHOICE IBBLK=$G(@VALMAR@("IDX",CHOICE,CHOICE))
- Q IBBLK
- EDITBLK ;allows user to select a blk, then displays it for edit
- ;allows user to discard or save changes to the block
- ;
- ;If IBBLK and IBBLK2 are used to point to two copies of the block, one in the workspace and the other on the form
- ;the copy on the form is not edited, the copy in the workspace is
- N IBBLK,IBBLK2,IBTKODR,IBJUNK,IFSAVE
- ;N IBMEMARY
- S VALMBCK="R"
- S IBBLK2=""
- S IBBLK=$$SELECT
- I IBBLK D
- .S (IBBLK2,IBTKODR,IBJUNK)=""
- .D COPYBLK^IBDF5B(IBBLK,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK) I 'IBBLK S IBBLK=IBBLK2,IBBLK2="" Q ;sets IBBLK to the work copy, IBBLK2 to the copy actually on the form
- D:IBBLK2 EN^VALM("IBDF FORM BLOCK EDIT")
- I IBBLK,IBBLK2 D
- .S IFSAVE=$$ASKSAVE^IBDF5B
- .I IFSAVE D SAVECOPY^IBDF5B(.IBBLK,.IBBLK2,IBTKODR) S IBBLK=IBBLK2,IBBLK2=""
- .I 'IFSAVE D DLTCOPY^IBDF5B(IBBLK) S IBBLK=IBBLK2,IBBLK2=""
- S IBPRINT("WITH_DATA")=0
- D:'$G(IBFASTXT) IDXBLKS^IBDF7
- Q
- DLTBLOCK ;allows user to select a blk, then deletes it
- N IBBLK
- S VALMBCK="R"
- S IBBLK=$$SELECT
- I IBBLK Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.1,IBBLK,0)),"^")) D DLTBLK^IBDFU3(IBBLK,IBFORM,357.1),IDXBLKS^IBDF7
- Q
- CHGORDER ;allows user to select a blk, then change it's order in the toolkit
- N IBBLK
- S VALMBCK="R"
- S IBBLK=$$SELECT
- I IBBLK K DIE,DA S DIE=357.1,DA=IBBLK,DR=".14R" D ^DIE K DIE,DA,DR,DIC
- D IDXBLKS^IBDF7
- Q
- NEWBLK ;creates a new toolkit block
- N IBBLK
- S VALMBCK="R"
- S IBBLK=$$CREATE^IBDF5C()
- D:IBBLK IDXBLKS^IBDF7
- Q
- COPYBLK ;allows the user to select a block to copy
- N IBBLK,CHOICE,NEWBLK
- S VALMBCK="R"
- D FULL^VALM1
- K DIR S DIR(0)="SO^1:ON THE LIST OF TOOLKIT BLOCKS;2:ON A TOOLKIT FORM;3:ON A FORM NOT IN THE TOOLKIT"
- S DIR("A")="WHERE IS THE BLOCK THAT YOU WANT COPIED?"
- D ^DIR K DIR
- Q:(Y=-1)!$D(DIRUT)
- S CHOICE=Y,IBBLK=""
- D:CHOICE=1 RE^VALM4
- S:CHOICE=1 IBBLK=$$SELECT
- S:CHOICE=2 IBBLK=$$SELECT2(1)
- S:CHOICE=3 IBBLK=$$SELECT2(0)
- I IBBLK S NEWBLK=$$COPYBLK^IBDFU2(IBBLK,IBFORM,357.1,357.1,0,0,$$TKORDER()) I NEWBLK D
- .K DIE,DA S DIE=357.1,DA=NEWBLK,DR=".01;.13R;.14R" D ^DIE
- .I '$G(DA) D DLTCNTNT^IBDFU3(NEWBLK,357.1)
- .K DIE,DA,DR,DIC
- .D IDXBLKS^IBDF7
- S VALMBCK="R"
- Q
- TKORDER() ;returns an unused number for the list of toolkit blocks
- N NUMBER
- F NUMBER=1:1:10000 Q:'$D(^IBE(357.1,"D",NUMBER))
- Q NUMBER
- SELECT2(TK) ;allows the user to select a form, then a block from it
- ;TK=0 if form is not to be chosen from the TK
- ;TK=1 if the form is to be chosen from the TK
- ;TK="" means ask the user whether or not the form is in the TK
- N IBFORM,IBBLK
- S IBBLK=""
- S IBFORM=$$SLCTFORM^IBDFU4($G(TK))
- I IBFORM D
- .W !!,"NOW CHOOSE THE BLOCK TO COPY!",!
- .S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
- Q IBBLK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF13 3691 printed Feb 19, 2025@00:17:08 Page 2
- IBDF13 ;ALB/CJM - ENCOUNTER FORM - EDITING TOOLKIT BLKS ; 24-JUN-1993
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- LIST ;displays list of toolkit blocks, then allows editng
- +1 NEW IBFORM,IBTKFORM,IBTKBLK,IBFASTXT,IOVL,IOHL,IOBRC,IOBLC,IOTRC,IOTLC,IBBLK,BLKLIST,D0,DA,IBDEVICE
- +2 SET (IBTKFORM,IBFASTXT,IBBLK)=0
- SET IBTKBLK=1
- +3 SET IBFORM("NAME")="LIST OF TOOLKIT BLOCKS"
- SET IBFORM("TOOLKIT")=1
- SET IBFORM("COMPILED")=0
- SET IBFORM("HT")=80
- SET IBFORM("WIDTH")=133
- SET IBFORM("PAGE_HT")=80
- SET IBFORM("PAGES")=1
- SET IBFORM("SCAN")=1
- SET IBFORM("SCAN","ICR")=1
- SET IBFORM("SCAN",1)=1
- +4 ;
- +5 DO DEVICE^IBDFUA(1,.IBDEVICE)
- +6 KILL XQORS,VALMEVL
- +7 DO PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,0)
- +8 SET IBFORM=$$TKFORM^IBDFU2C
- +9 ;list processor displays list of toolkit blocks
- DO EN^VALM("IBDF EDIT TOOL KIT BLOCKS")
- +10 QUIT
- +11 ;
- SELECT() ;allows the user to select from the displayed list of TK blocks
- +1 NEW CHOICE,IBBLK
- +2 SET IBBLK=""
- +3 DO EN^VALM2($GET(XQORNOD(0)),"S")
- +4 SET CHOICE=$ORDER(VALMY(""))
- if CHOICE
- SET IBBLK=$GET(@VALMAR@("IDX",CHOICE,CHOICE))
- +5 QUIT IBBLK
- EDITBLK ;allows user to select a blk, then displays it for edit
- +1 ;allows user to discard or save changes to the block
- +2 ;
- +3 ;If IBBLK and IBBLK2 are used to point to two copies of the block, one in the workspace and the other on the form
- +4 ;the copy on the form is not edited, the copy in the workspace is
- +5 NEW IBBLK,IBBLK2,IBTKODR,IBJUNK,IFSAVE
- +6 ;N IBMEMARY
- +7 SET VALMBCK="R"
- +8 SET IBBLK2=""
- +9 SET IBBLK=$$SELECT
- +10 IF IBBLK
- Begin DoDot:1
- +11 SET (IBBLK2,IBTKODR,IBJUNK)=""
- +12 ;sets IBBLK to the work copy, IBBLK2 to the copy actually on the form
- DO COPYBLK^IBDF5B(IBBLK,.IBBLK2,.IBBLK,.IBTKODR,.IBJUNK)
- IF 'IBBLK
- SET IBBLK=IBBLK2
- SET IBBLK2=""
- QUIT
- End DoDot:1
- +13 if IBBLK2
- DO EN^VALM("IBDF FORM BLOCK EDIT")
- +14 IF IBBLK
- IF IBBLK2
- Begin DoDot:1
- +15 SET IFSAVE=$$ASKSAVE^IBDF5B
- +16 IF IFSAVE
- DO SAVECOPY^IBDF5B(.IBBLK,.IBBLK2,IBTKODR)
- SET IBBLK=IBBLK2
- SET IBBLK2=""
- +17 IF 'IFSAVE
- DO DLTCOPY^IBDF5B(IBBLK)
- SET IBBLK=IBBLK2
- SET IBBLK2=""
- End DoDot:1
- +18 SET IBPRINT("WITH_DATA")=0
- +19 if '$GET(IBFASTXT)
- DO IDXBLKS^IBDF7
- +20 QUIT
- DLTBLOCK ;allows user to select a blk, then deletes it
- +1 NEW IBBLK
- +2 SET VALMBCK="R"
- +3 SET IBBLK=$$SELECT
- +4 IF IBBLK
- if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.1,IBBLK,0)),"^"))
- QUIT
- DO DLTBLK^IBDFU3(IBBLK,IBFORM,357.1)
- DO IDXBLKS^IBDF7
- +5 QUIT
- CHGORDER ;allows user to select a blk, then change it's order in the toolkit
- +1 NEW IBBLK
- +2 SET VALMBCK="R"
- +3 SET IBBLK=$$SELECT
- +4 IF IBBLK
- KILL DIE,DA
- SET DIE=357.1
- SET DA=IBBLK
- SET DR=".14R"
- DO ^DIE
- KILL DIE,DA,DR,DIC
- +5 DO IDXBLKS^IBDF7
- +6 QUIT
- NEWBLK ;creates a new toolkit block
- +1 NEW IBBLK
- +2 SET VALMBCK="R"
- +3 SET IBBLK=$$CREATE^IBDF5C()
- +4 if IBBLK
- DO IDXBLKS^IBDF7
- +5 QUIT
- COPYBLK ;allows the user to select a block to copy
- +1 NEW IBBLK,CHOICE,NEWBLK
- +2 SET VALMBCK="R"
- +3 DO FULL^VALM1
- +4 KILL DIR
- SET DIR(0)="SO^1:ON THE LIST OF TOOLKIT BLOCKS;2:ON A TOOLKIT FORM;3:ON A FORM NOT IN THE TOOLKIT"
- +5 SET DIR("A")="WHERE IS THE BLOCK THAT YOU WANT COPIED?"
- +6 DO ^DIR
- KILL DIR
- +7 if (Y=-1)!$DATA(DIRUT)
- QUIT
- +8 SET CHOICE=Y
- SET IBBLK=""
- +9 if CHOICE=1
- DO RE^VALM4
- +10 if CHOICE=1
- SET IBBLK=$$SELECT
- +11 if CHOICE=2
- SET IBBLK=$$SELECT2(1)
- +12 if CHOICE=3
- SET IBBLK=$$SELECT2(0)
- +13 IF IBBLK
- SET NEWBLK=$$COPYBLK^IBDFU2(IBBLK,IBFORM,357.1,357.1,0,0,$$TKORDER())
- IF NEWBLK
- Begin DoDot:1
- +14 KILL DIE,DA
- SET DIE=357.1
- SET DA=NEWBLK
- SET DR=".01;.13R;.14R"
- DO ^DIE
- +15 IF '$GET(DA)
- DO DLTCNTNT^IBDFU3(NEWBLK,357.1)
- +16 KILL DIE,DA,DR,DIC
- +17 DO IDXBLKS^IBDF7
- End DoDot:1
- +18 SET VALMBCK="R"
- +19 QUIT
- TKORDER() ;returns an unused number for the list of toolkit blocks
- +1 NEW NUMBER
- +2 FOR NUMBER=1:1:10000
- if '$DATA(^IBE(357.1,"D",NUMBER))
- QUIT
- +3 QUIT NUMBER
- SELECT2(TK) ;allows the user to select a form, then a block from it
- +1 ;TK=0 if form is not to be chosen from the TK
- +2 ;TK=1 if the form is to be chosen from the TK
- +3 ;TK="" means ask the user whether or not the form is in the TK
- +4 NEW IBFORM,IBBLK
- +5 SET IBBLK=""
- +6 SET IBFORM=$$SLCTFORM^IBDFU4($GET(TK))
- +7 IF IBFORM
- Begin DoDot:1
- +8 WRITE !!,"NOW CHOOSE THE BLOCK TO COPY!",!
- +9 SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
- End DoDot:1
- +10 QUIT IBBLK