IBDF7.m

IBDF7 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(ADDING TOOLKIT BLKS) ; 08-JAN-1993

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

 ;

ADD ;create a new block by copying a toolkit block

 N BLKLIST,OLDBLOCK,NEWBLOCK,TOP,BOT,IBBG,IBLFT

 S VALMBCK="R",IBBG=+$G(VALMBG),OLDBLOCK="",IBLFT=+$G(VALMLFT)

 D EN^VALM("IBDF TOOL KIT BLOCK LIST") ;list processor displays list of tool kit blocks

 I '$G(IBFASTXT) D

 .S VALMBG=IBBG S:VALMBG<1 VALMBG=1

 .Q:OLDBLOCK=""  ;selected tool kit block stored in OLDBLOCK

 .S NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,IBFORM,357.1,357.1,IBBG-1,IBLFT-5,0,"",1)

 .D RE^VALM4,POS^IBDFU4(NEWBLOCK)

 .S VALMBCK="R"

 .D TOPNBOT^IBDFU5(NEWBLOCK,.TOP,.BOT)

 .D IDXFORM^IBDF5A(TOP,BOT)

 Q

 ;

INIT ;entry code to list

 S BLKLIST="^TMP(""IBDF"",$J,""TOOL KIT BLOCK LIST"")"

 D IDXBLKS

 Q

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !

 Q

 ;

EXIT ; -- exit code

 K @BLKLIST

 Q

 ;

IDXBLKS ; sets up list of toolkit blocks for list processor

 N BLOCK,TK

 K @BLKLIST

 S VALMCNT=0

 S TK=0,BLOCK="" F  S TK=$O(^IBE(357.1,"D",TK)) Q:'TK  F  S BLOCK=$O(^IBE(357.1,"D",TK,BLOCK)) Q:'BLOCK  D

 .Q:'$P($G(^IBE(357.1,BLOCK,0)),"^",14)

 .S VALMCNT=VALMCNT+1

 .S @BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT,TK),@BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK

 .D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column

 Q

 ;

DISPLAY(BLOCK,ID,TKORDER) ;adds one toolkit block to the list array

 N NODE,NAME,DESCR,RET

 ;** note: IBTKBLK=1 only if editing the tool kit blocks - display the tool kit order in that case

 S RET=$J(ID,3)_$$PADRIGHT^IBDFU("",2)

 S NODE=$G(^IBE(357.1,BLOCK,0))

 S NAME=$P(NODE,"^",1),DESCR=$P(NODE,"^",13)

 S RET=RET_$$PADRIGHT^IBDFU(NAME,30)_" "

 I $G(IBTKBLK) S RET=RET_$E($J(TKORDER,4),1,4)_"  "

 S RET=RET_$E(DESCR,1,80)

 Q RET

SELECT ;

 N CHOICE

 D EN^VALM2($G(XQORNOD(0)),"S")

 S CHOICE=$O(VALMY("")) Q:'CHOICE  S OLDBLOCK=$G(@VALMAR@("IDX",CHOICE,CHOICE))

 Q

IBDF7     ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(ADDING TOOLKIT BLKS) ; 08-JAN-1993

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

 +2       ;

ADD       ;create a new block by copying a toolkit block

 +1        NEW BLKLIST,OLDBLOCK,NEWBLOCK,TOP,BOT,IBBG,IBLFT

 +2        SET VALMBCK="R"

           SET IBBG=+$GET(VALMBG)

           SET OLDBLOCK=""

           SET IBLFT=+$GET(VALMLFT)

 +3       ;list processor displays list of tool kit blocks

           DO EN^VALM("IBDF TOOL KIT BLOCK LIST")

 +4        IF '$GET(IBFASTXT)

               Begin DoDot:1

 +5                SET VALMBG=IBBG

                   IF VALMBG<1

                       SET VALMBG=1

 +6       ;selected tool kit block stored in OLDBLOCK

                   IF OLDBLOCK=""

                       QUIT 

 +7                SET NEWBLOCK=$$COPYBLK^IBDFU2(OLDBLOCK,IBFORM,357.1,357.1,IBBG-1,IBLFT-5,0,"",1)

 +8                DO RE^VALM4

                   DO POS^IBDFU4(NEWBLOCK)

 +9                SET VALMBCK="R"

 +10               DO TOPNBOT^IBDFU5(NEWBLOCK,.TOP,.BOT)

 +11               DO IDXFORM^IBDF5A(TOP,BOT)

               End DoDot:1

 +12       QUIT 

 +13      ;

INIT      ;entry code to list

 +1        SET BLKLIST="^TMP(""IBDF"",$J,""TOOL KIT BLOCK LIST"")"

 +2        DO IDXBLKS

 +3        QUIT 

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL @BLKLIST

 +2        QUIT 

 +3       ;

IDXBLKS   ; sets up list of toolkit blocks for list processor

 +1        NEW BLOCK,TK

 +2        KILL @BLKLIST

 +3        SET VALMCNT=0

 +4        SET TK=0

           SET BLOCK=""

           FOR 

               SET TK=$ORDER(^IBE(357.1,"D",TK))

               IF 'TK

                   QUIT 

               FOR 

                   SET BLOCK=$ORDER(^IBE(357.1,"D",TK,BLOCK))

                   IF 'BLOCK

                       QUIT 

                   Begin DoDot:1

 +5                    IF '$PIECE($GET(^IBE(357.1,BLOCK,0)),"^",14)

                           QUIT 

 +6                    SET VALMCNT=VALMCNT+1

 +7                    SET @BLKLIST@(VALMCNT,0)=$$DISPLAY(BLOCK,VALMCNT,TK)

                       SET @BLKLIST@("IDX",VALMCNT,VALMCNT)=BLOCK

 +8       ;set video for ID column

                       DO FLDCTRL^VALM10(VALMCNT,"ID")

                   End DoDot:1

 +9        QUIT 

 +10      ;

DISPLAY(BLOCK,ID,TKORDER) ;adds one toolkit block to the list array

 +1        NEW NODE,NAME,DESCR,RET

 +2       ;** note: IBTKBLK=1 only if editing the tool kit blocks - display the tool kit order in that case

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

 +4        SET NODE=$GET(^IBE(357.1,BLOCK,0))

 +5        SET NAME=$PIECE(NODE,"^",1)

           SET DESCR=$PIECE(NODE,"^",13)

 +6        SET RET=RET_$$PADRIGHT^IBDFU(NAME,30)_" "

 +7        IF $GET(IBTKBLK)

               SET RET=RET_$EXTRACT($JUSTIFY(TKORDER,4),1,4)_"  "

 +8        SET RET=RET_$EXTRACT(DESCR,1,80)

 +9        QUIT RET

SELECT    ;

 +1        NEW CHOICE

 +2        DO EN^VALM2($GET(XQORNOD(0)),"S")

 +3        SET CHOICE=$ORDER(VALMY(""))

           IF 'CHOICE

               QUIT 

           SET OLDBLOCK=$GET(@VALMAR@("IDX",CHOICE,CHOICE))

 +4        QUIT