Routine: IBDE

IBDE ;ALB/CJM - ENCOUNTER FORM - IMP/EXP UTILITY ;AUG 12,1993

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

MAIN ;

 N FORMLIST,BLKLIST,FORMCNT,BLKCNT,IBTKBLK,SCREEN

 S SCREEN="F" ;a flag that indicates wheter user is looking at the block screen(=B) or the form screen(=F)

 S IBTKBLK=0 ;if 1 overrides check preventing deletion of tk blocks

 K XQORS,VALMEVL

 D EN^VALM("IBDE IMP/EXP FORMS")

HDR ;

 S VALMHDR(1)="LIST OF FORMS READY FOR IMPORT OR EXPORT"

 S VALMHDR(3)="(** there are "_$S($O(^IBE(358.1,"D",0)):"also",1:"no")_" toolkit blocks in the work space **)"

ONENTRY ;

 S FORMLIST="^TMP(""IBDF"",$J,""IMP/EXP WS"",""FORMS"")"

 S BLKLIST="^TMP(""IBDF"",$J,""IMP/EXP WS"",""BLOCKS"")"

 D IDXBLKS^IBDE3,IDXFORMS

ONEXIT ;

 K ^TMP("IBDF",$J,"IMP/EXP WS"),VALMY,VALMBCK,X,Y,I,DA,D0

IDXFORMS ;build an array of forms used by IBCLINIC for the list processor

 N FORM,NODE

 K @FORMLIST

 S (FORM,VALMCNT)=0 F  S FORM=$O(^IBE(358,FORM)) Q:'FORM  D

 .I $D(^IBE(358,FORM,0)) D

 ..S VALMCNT=VALMCNT+1,@FORMLIST@(VALMCNT,0)=$$DISPLAY(FORM,VALMCNT),@FORMLIST@("IDX",VALMCNT,VALMCNT)=FORM D FLDCTRL^VALM10(VALMCNT) ;set video for ID column

 S FORMCNT=VALMCNT

DISPLAY(FORM,ID) ;

 N NODE,RET

 S RET=$J(ID,3)_"  "

 S NODE=$G(^IBE(358,FORM,0))

 S RET=RET_$$PADRIGHT^IBDFU($P(NODE,"^",1),30)_"  "_$P(NODE,"^",3)

 Q RET

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDE   1368     printed  Dec 13, 2024@01:38:45                                                                                                                                                                                                        Page 2

IBDE      ;ALB/CJM - ENCOUNTER FORM - IMP/EXP UTILITY ;AUG 12,1993

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

MAIN      ;

 +1        NEW FORMLIST,BLKLIST,FORMCNT,BLKCNT,IBTKBLK,SCREEN

 +2       ;a flag that indicates wheter user is looking at the block screen(=B) or the form screen(=F)

           SET SCREEN="F"

 +3       ;if 1 overrides check preventing deletion of tk blocks

           SET IBTKBLK=0

 +4        KILL XQORS,VALMEVL

 +5        DO EN^VALM("IBDE IMP/EXP FORMS")

 +6        QUIT

HDR       ;

 +1        SET VALMHDR(1)="LIST OF FORMS READY FOR IMPORT OR EXPORT"

 +2        SET VALMHDR(3)="(** there are "_$SELECT($ORDER(^IBE(358.1,"D",0)):"also",1:"no")_" toolkit blocks in the work space **)"

 +3        QUIT

ONENTRY   ;

 +1        SET FORMLIST="^TMP(""IBDF"",$J,""IMP/EXP WS"",""FORMS"")"

 +2        SET BLKLIST="^TMP(""IBDF"",$J,""IMP/EXP WS"",""BLOCKS"")"

 +3        DO IDXBLKS^IBDE3

           DO IDXFORMS

 +4        QUIT

ONEXIT    ;

 +1        KILL ^TMP("IBDF",$JOB,"IMP/EXP WS"),VALMY,VALMBCK,X,Y,I,DA,D0

 +2        QUIT

 +3       ;

IDXFORMS  ;build an array of forms used by IBCLINIC for the list processor

 +1        NEW FORM,NODE

 +2        KILL @FORMLIST

 +3        SET (FORM,VALMCNT)=0

FOR

               SET FORM=$ORDER(^IBE(358,FORM))

               if 'FORM

                   QUIT

               Begin DoDot:1

 +4                IF $DATA(^IBE(358,FORM,0))

                       Begin DoDot:2

 +5       ;set video for ID column

                           SET VALMCNT=VALMCNT+1

                           SET @FORMLIST@(VALMCNT,0)=$$DISPLAY(FORM,VALMCNT)

                           SET @FORMLIST@("IDX",VALMCNT,VALMCNT)=FORM

                           DO FLDCTRL^VALM10(VALMCNT)

                       End DoDot:2

               End DoDot:1

 +6        SET FORMCNT=VALMCNT

 +7        QUIT

 +8       ;

DISPLAY(FORM,ID) ;

 +1        NEW NODE,RET

 +2        SET RET=$JUSTIFY(ID,3)_"  "

 +3        SET NODE=$GET(^IBE(358,FORM,0))

 +4        SET RET=RET_$$PADRIGHT^IBDFU($PIECE(NODE,"^",1),30)_"  "_$PIECE(NODE,"^",3)

 +5        QUIT RET

IBDE.m