IBDE1 ;ALB/CJM - ENCOUNTER FORM - (IMP/EXP UTILITY ACTIONS) ;AUG 12,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
;
ADD ;adds a form to the work space
N OLDFORM,NEWFORM
D FULL^VALM1
S VALMBCK="R"
S OLDFORM=$$SLCTFORM^IBDFU4("") Q:'OLDFORM
S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,358,"",1)
I NEWFORM K DIE,DR,DA S DIE="^IBE(358,",DA=NEWFORM,DR="1;" D ^DIE K DIE,DR,DA
D IDXFORMS^IBDE
Q
;
DELETE ;deletes a form from the work space
N PICK,FORM
D EN^VALM2($G(XQORNOD(0)))
S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S FORM=+$G(@VALMAR@("IDX",PICK,PICK)) D:FORM DELETE^IBDFU2C(FORM,358,1)
S VALMBCK="R"
D IDXFORMS^IBDE
Q
EDIT ;allows the export notes of a form to be edited
N PICK,FORM
D EN^VALM2($G(XQORNOD(0)))
D FULL^VALM1
S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S FORM=+$G(@VALMAR@("IDX",PICK,PICK)) D:FORM
.K DIE,DR,DA S DIE="^IBE(358,",DR="1;",DA=FORM D ^DIE K DIE,DA,DR
S VALMBCK="R"
D IDXFORMS^IBDE
Q
IMPORT ;allows the user to pick a form, then import it
N PICK,FORM,NAME,NEWFORM,IBDVR,FORMVR
D EN^VALM2($G(XQORNOD(0)))
D FULL^VALM1
S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S FORM=+$G(@VALMAR@("IDX",PICK,PICK)) D:FORM
.S IBDVR=+$G(^DD(357,0,"VR")) S:IBDVR<2.1 IBDVR=3.0
.S FORMVR=+$P($G(^IBE(358,FORM,0)),"^",17) S:FORMVR<2.1 FORMVR=2.0
.I FORMVR<IBDVR W !!,"This form was created with version "_FORMVR_"." D
..; -- ask if want to continue, if not quit
..;
.S NAME=$$NEWNAME^IBDFU2C($P($G(^IBE(358,FORM,0)),"^"))
.Q:NAME=""
.S NEWFORM=$$COPYFORM^IBDFU2C(FORM,358,357,NAME)
.K DIE,DR,DA S DIE="^IBE(357,",DR=".07T;.04////1;",DA=NEWFORM D ^DIE K DIE,DA,DR
.D:$G(NEWFORM) DELETE^IBDFU2C(FORM,358,0)
S VALMBCK="R"
D IDXFORMS^IBDE
D UPDATE^IBDECLN(1) ;make sure everything is okay (with messages)
Q
VIEW ;allows the export notes of a form to be edited
N PICK,FORM,IBARY,IBHDRRTN
D EN^VALM2($G(XQORNOD(0)),"S")
S PICK="" F S PICK=$O(VALMY(PICK)) Q:'PICK S FORM=+$G(@VALMAR@("IDX",PICK,PICK)) D
.S IBHDRRTN="D VIEWHDR^IBDE1"
.S IBARY="^IBE(358,"_FORM_",1)"
.D EN^VALM("IBDE TEXT DISPLAY")
S VALMBCK="R"
Q
VIEWHDR ;
S VALMHDR(1)="Export Notes For "_$P($G(^IBE(358,FORM,0)),"^")_" Form"
Q
TEXT ;entry code for the IBDF TEXT DISPLAY list template
N NODE S NODE=""
S:$D(IBARY) VALMAR=IBARY
X:$D(IBHDRRTN) IBHDRRTN
I $G(IBARY)'="" S NODE=$G(@IBARY@(0))
S VALMCNT=$S($P(NODE,"^",4)>$P(NODE,"^",3):$P(NODE,"^",4),1:$P(NODE,"^",3))
I '$G(VALMCNT) S VALMCNT=10
Q
;
INITS ;executes inits to bring stuff into the imp/exp files
N QUIT,RTN
S QUIT=0
S VALMBCK="R"
I $G(DUZ(0))'["@" W !,"This action requires PROGRAMMER ACCESS!" D PAUSE^IBDFU5 Q
D FULL^VALM1
I BLKCNT!FORMCNT D
.K DIR S DIR(0)="Y"
.W !,"The work space must be cleared before the INITS are run. Is that okay?"
.D ^DIR K DIR
.I $D(DIRUT)!(Y=0) S QUIT=1
D:'QUIT DLTALL^IBDE2
;
;ask for the init rtn
F Q:QUIT D
.S DIR(0)="FA^5:8",DIR("B")=$S($L($T(^IBDEINIT)):"IBDEINIT",1:"")
.S DIR("?",1)="In order for you to import forms from another site the other site must have",DIR("?")="prepared and sent you inits created using the import/export facility."
.S DIR("A",1)="What is the name of the init routine that contains the forms that you want to",DIR("A")="import? "
.D ^DIR K DIR
.I $D(DIRUT) S QUIT=1 Q
.I '$L($T(^@Y)) W !!,"That routine does not exist!",! Q
.S RTN=Y
.S QUIT=$$MSG^IBDE1B
.I 'QUIT D @("^"_RTN),IDXFORMS^IBDE,IDXBLKS^IBDE3 S VALMCNT=$S(SCREEN="F":FORMCNT,1:BLKCNT)
.S QUIT=1
I SCREEN="F" D HDR^IBDE
I SCREEN="B" D HDR^IBDE3
Q
DIFROM ;
N QUIT S QUIT=0
S VALMBCK=""
I $G(DUZ(0))'["@" W !!,"Using the DIFROM action requires PROGRAMMER ACCESS!",! D PAUSE^IBDFU5 Q
I 'BLKCNT,'FORMCNT D Q
.W !!,"There is nothing in the work space to export!"
.D PAUSE^IBDFU5
D FULL^VALM1
S QUIT=$$MSG^IBDE1A
I 'QUIT D ^DIFROM W !,"DONE",!,"************************"
S VALMBCK="R"
Q
BLOCKS ;
S SCREEN="B"
D EN^VALM("IBDE IMP/EXP TK BLOCKS")
S VALMBCK="R",VALMCNT=FORMCNT,SCREEN="F"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDE1 4071 printed Apr 09, 2024@21:28:30 Page 2
IBDE1 ;ALB/CJM - ENCOUNTER FORM - (IMP/EXP UTILITY ACTIONS) ;AUG 12,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
+2 ;
ADD ;adds a form to the work space
+1 NEW OLDFORM,NEWFORM
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 SET OLDFORM=$$SLCTFORM^IBDFU4("")
if 'OLDFORM
QUIT
+5 SET NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,358,"",1)
+6 IF NEWFORM
KILL DIE,DR,DA
SET DIE="^IBE(358,"
SET DA=NEWFORM
SET DR="1;"
DO ^DIE
KILL DIE,DR,DA
+7 DO IDXFORMS^IBDE
+8 QUIT
+9 ;
DELETE ;deletes a form from the work space
+1 NEW PICK,FORM
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 SET PICK=""
FOR
SET PICK=$ORDER(VALMY(PICK))
if 'PICK
QUIT
SET FORM=+$GET(@VALMAR@("IDX",PICK,PICK))
if FORM
DO DELETE^IBDFU2C(FORM,358,1)
+4 SET VALMBCK="R"
+5 DO IDXFORMS^IBDE
+6 QUIT
EDIT ;allows the export notes of a form to be edited
+1 NEW PICK,FORM
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 DO FULL^VALM1
+4 SET PICK=""
FOR
SET PICK=$ORDER(VALMY(PICK))
if 'PICK
QUIT
SET FORM=+$GET(@VALMAR@("IDX",PICK,PICK))
if FORM
Begin DoDot:1
+5 KILL DIE,DR,DA
SET DIE="^IBE(358,"
SET DR="1;"
SET DA=FORM
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+6 SET VALMBCK="R"
+7 DO IDXFORMS^IBDE
+8 QUIT
IMPORT ;allows the user to pick a form, then import it
+1 NEW PICK,FORM,NAME,NEWFORM,IBDVR,FORMVR
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 DO FULL^VALM1
+4 SET PICK=""
FOR
SET PICK=$ORDER(VALMY(PICK))
if 'PICK
QUIT
SET FORM=+$GET(@VALMAR@("IDX",PICK,PICK))
if FORM
Begin DoDot:1
+5 SET IBDVR=+$GET(^DD(357,0,"VR"))
if IBDVR<2.1
SET IBDVR=3.0
+6 SET FORMVR=+$PIECE($GET(^IBE(358,FORM,0)),"^",17)
if FORMVR<2.1
SET FORMVR=2.0
+7 IF FORMVR<IBDVR
WRITE !!,"This form was created with version "_FORMVR_"."
Begin DoDot:2
+8 ; -- ask if want to continue, if not quit
+9 ;
End DoDot:2
+10 SET NAME=$$NEWNAME^IBDFU2C($PIECE($GET(^IBE(358,FORM,0)),"^"))
+11 if NAME=""
QUIT
+12 SET NEWFORM=$$COPYFORM^IBDFU2C(FORM,358,357,NAME)
+13 KILL DIE,DR,DA
SET DIE="^IBE(357,"
SET DR=".07T;.04////1;"
SET DA=NEWFORM
DO ^DIE
KILL DIE,DA,DR
+14 if $GET(NEWFORM)
DO DELETE^IBDFU2C(FORM,358,0)
End DoDot:1
+15 SET VALMBCK="R"
+16 DO IDXFORMS^IBDE
+17 ;make sure everything is okay (with messages)
DO UPDATE^IBDECLN(1)
+18 QUIT
VIEW ;allows the export notes of a form to be edited
+1 NEW PICK,FORM,IBARY,IBHDRRTN
+2 DO EN^VALM2($GET(XQORNOD(0)),"S")
+3 SET PICK=""
FOR
SET PICK=$ORDER(VALMY(PICK))
if 'PICK
QUIT
SET FORM=+$GET(@VALMAR@("IDX",PICK,PICK))
Begin DoDot:1
+4 SET IBHDRRTN="D VIEWHDR^IBDE1"
+5 SET IBARY="^IBE(358,"_FORM_",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,FORM,0)),"^")_" Form"
+2 QUIT
TEXT ;entry code for the IBDF TEXT DISPLAY list template
+1 NEW NODE
SET NODE=""
+2 if $DATA(IBARY)
SET VALMAR=IBARY
+3 if $DATA(IBHDRRTN)
XECUTE IBHDRRTN
+4 IF $GET(IBARY)'=""
SET NODE=$GET(@IBARY@(0))
+5 SET VALMCNT=$SELECT($PIECE(NODE,"^",4)>$PIECE(NODE,"^",3):$PIECE(NODE,"^",4),1:$PIECE(NODE,"^",3))
+6 IF '$GET(VALMCNT)
SET VALMCNT=10
+7 QUIT
+8 ;
INITS ;executes inits to bring stuff into the imp/exp files
+1 NEW QUIT,RTN
+2 SET QUIT=0
+3 SET VALMBCK="R"
+4 IF $GET(DUZ(0))'["@"
WRITE !,"This action requires PROGRAMMER ACCESS!"
DO PAUSE^IBDFU5
QUIT
+5 DO FULL^VALM1
+6 IF BLKCNT!FORMCNT
Begin DoDot:1
+7 KILL DIR
SET DIR(0)="Y"
+8 WRITE !,"The work space must be cleared before the INITS are run. Is that okay?"
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)!(Y=0)
SET QUIT=1
End DoDot:1
+11 if 'QUIT
DO DLTALL^IBDE2
+12 ;
+13 ;ask for the init rtn
+14 FOR
if QUIT
QUIT
Begin DoDot:1
+15 SET DIR(0)="FA^5:8"
SET DIR("B")=$SELECT($LENGTH($TEXT(^IBDEINIT)):"IBDEINIT",1:"")
+16 SET DIR("?",1)="In order for you to import forms from another site the other site must have"
SET DIR("?")="prepared and sent you inits created using the import/export facility."
+17 SET DIR("A",1)="What is the name of the init routine that contains the forms that you want to"
SET DIR("A")="import? "
+18 DO ^DIR
KILL DIR
+19 IF $DATA(DIRUT)
SET QUIT=1
QUIT
+20 IF '$LENGTH($TEXT(^@Y))
WRITE !!,"That routine does not exist!",!
QUIT
+21 SET RTN=Y
+22 SET QUIT=$$MSG^IBDE1B
+23 IF 'QUIT
DO @("^"_RTN)
DO IDXFORMS^IBDE
DO IDXBLKS^IBDE3
SET VALMCNT=$SELECT(SCREEN="F":FORMCNT,1:BLKCNT)
+24 SET QUIT=1
End DoDot:1
+25 IF SCREEN="F"
DO HDR^IBDE
+26 IF SCREEN="B"
DO HDR^IBDE3
+27 QUIT
DIFROM ;
+1 NEW QUIT
SET QUIT=0
+2 SET VALMBCK=""
+3 IF $GET(DUZ(0))'["@"
WRITE !!,"Using the DIFROM action requires PROGRAMMER ACCESS!",!
DO PAUSE^IBDFU5
QUIT
+4 IF 'BLKCNT
IF 'FORMCNT
Begin DoDot:1
+5 WRITE !!,"There is nothing in the work space to export!"
+6 DO PAUSE^IBDFU5
End DoDot:1
QUIT
+7 DO FULL^VALM1
+8 SET QUIT=$$MSG^IBDE1A
+9 IF 'QUIT
DO ^DIFROM
WRITE !,"DONE",!,"************************"
+10 SET VALMBCK="R"
+11 QUIT
BLOCKS ;
+1 SET SCREEN="B"
+2 DO EN^VALM("IBDE IMP/EXP TK BLOCKS")
+3 SET VALMBCK="R"
SET VALMCNT=FORMCNT
SET SCREEN="F"
+4 QUIT
