IBDFQSL1.m

IBDFQSL1 ;ALB/CJM/AAS/MAF - ENCOUNTER FORM - Quick selection edit (cont.);12-Jun-95

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

EN ; -- main entry point for IBDF QUICK SELECTION EDIT

 D EN^VALM("IBDF QUICK SELECTION EDIT")

 Q

 ;

HDR ; -- header code

 S VALMHDR(1)="This screen displays the selection list for ' "_$P(^IBE(357.1,IBBLK,0),"^",1)_" '"

 S VALMHDR(2)="on Encounter Form ' "_$P(^IBE(357,IBFORM,0),"^",1)_" '"

 Q

 ;

INIT ; -- init variables and list array

 N IBDCNT,IBDCNT1

 W !,"Please wait while I build the list..."

 K ^TMP("SEL",$J),^TMP("SELIDX",$J),IBDFHDR D KILL^VALM10()

 S (IBDCNT,IBDCNT1,VALMCNT)=0

 S IBDLSTNM=$P(^IBE(357.2,IBLIST,0),"^",1) D INTER D

 .S IBLSNODE=$G(^IBE(357.2,IBLIST,0))

 .I $D(IBDFAR) F IBDFX=0:0 S IBDFX=$O(@(IBDFAR_"("_IBDFX_")")) Q:'IBDFX  S IBDFARR=$G(@(IBDFAR_"("_IBDFX_")")) D:$P(IBDFARR,"^",1)="" HEADER D:$P(IBDFARR,"^",1)]"" SETARR

 Q:$$LSTDESCR^IBDFU1(.IBLIST) 1

 S IBRTN=IBLIST("RTN")

 D RTNDSCR^IBDFU1B(.IBRTN)

 I '$D(^TMP("SEL",$J)) D NUL

 Q

 ;

SETARR ;  -- Set up Listman array

 N IBDFNODE

 W "."

 S IBDFNODE=IBDFARR

 S IBDFSEL=$P(IBDFNODE,"^",4)

 S IBDCNT1=IBDCNT1+1

 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1

 S X=""

 S IBDFVAL=$J(IBDCNT1_")",5)

 S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)

 S IBDFVAL=$P(IBDFNODE,"^",1)

 S X=$$SETSTR^VALM1(IBDFVAL,X,7,7)

 S IBDFVAL=$P(IBDFNODE,"^",6)

 S X=$$SETSTR^VALM1(IBDFVAL,X,16,5)

 S IBDFVAL=$P(IBDFNODE,"^",2)

 S X=$$SETSTR^VALM1(IBDFVAL,X,23,40)

 S IBDFVAL=$P(^IBE(357.4,$P(IBDFNODE,"^",5),0),"^",1)

 S X=$$SETSTR^VALM1(IBDFVAL,X,64,15)

 I $D(^IBE(357.3,$P(IBDFNODE,"^",4),2)) D

 .S IBDFVAL=$P(^IBE(357.3,$P(IBDFNODE,"^",4),2),"^")

 .S X=$$SETSTR^VALM1(IBDFVAL,X,81,26)

 .S IBDFVAL=$P(^IBE(357.3,$P(IBDFNODE,"^",4),2),"^",2)

 .I $D(^LEX(757.01)) S IBDFVAL=$P($G(^LEX(757.01,+IBDFVAL,0)),"^")

 .E  S IBDFVAL=$P($G(^GMP(757.01,+IBDFVAL,0)),"^")

 .S X=$$SETSTR^VALM1(IBDFVAL,X,109,23)

TMP ; -- Set up TMP Array

 S ^TMP("SEL",$J,IBDCNT,0)=X,^TMP("SEL",$J,"IDX",VALMCNT,IBDCNT1)=IBDFSEL

 S ^TMP("SELIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFARR,"^",3)_"^"_$P(IBDFARR,"^",4)_"^"_$P(IBDFARR,"^",5) ;_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)

 Q

HEADER ;  -- Set up header line for the display

 S IBDCNT1=IBDCNT1+1

 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1

 S X=""

 S IBDVAL=$S($P(IBDFARR,"^",2)]"":$P(IBDFARR,"^",2),1:"BLANK")

 S IBDFHDR(IBDVAL)=IBDCNT_"^"_$P(IBDFARR,"^",5)

 S IBDFSEL=$P(IBDFARR,"^",5)

 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP

 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1

 S IBDVAL=$P(IBDFARR,"^",6)

 S X=$$SETSTR^VALM1(IBDVAL,X,16,5)

 S IBDVAL=$P(IBDFARR,"^",2)

 S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,22,IBDVAL1)

 S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)

 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1

 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP

 S IBDCNT1=IBDCNT1-1

 Q

INTER ;  -- Find Package interface for selection list

 K IBARRY S IBDFAR="IBARRY",IBDFINT=$P($G(^IBE(357.2,IBLIST,0)),"^",11),IBDFINT(1)=$P(^IBE(357.6,IBDFINT,0),"^",1) D GETLST^IBDFQSL2(IBFORM,IBBLK,IBLIST,.IBDFINT,"IBARRY",1)

 Q

HELP ; -- help code

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

 Q

 ;

EXIT ; -- exit code

 K IBARRY,IBDFAR,IBDFARR,IBDFHDR,IBDFINT,IBDFSEL,IBDFVAL,IBDFX,IBDLSTNM,IBDVAL,IBDVAL1,IBLIST,IBRTN,IEN,IBLSNODE,DIC,IBGRP,NODE

 K ^TMP("SEL",$J),^TMP("SELIDX",$J)

 Q

 ;

EXPND ; -- expand code

 Q

 ;

NUL ;  -- Null message

 S ^TMP("SEL",$J,1,0)=" ",^TMP("SEL",$J,2,0)="There are no selection lists for this block.",^TMP("SELIDX",$J,1)=1,^TMP("SELIDX",$J,2)=2

 Q

IBDFQSL1  ;ALB/CJM/AAS/MAF - ENCOUNTER FORM - Quick selection edit (cont.);12-Jun-95

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

EN        ; -- main entry point for IBDF QUICK SELECTION EDIT

 +1        DO EN^VALM("IBDF QUICK SELECTION EDIT")

 +2        QUIT 

 +3       ;

HDR       ; -- header code

 +1        SET VALMHDR(1)="This screen displays the selection list for ' "_$PIECE(^IBE(357.1,IBBLK,0),"^",1)_" '"

 +2        SET VALMHDR(2)="on Encounter Form ' "_$PIECE(^IBE(357,IBFORM,0),"^",1)_" '"

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        NEW IBDCNT,IBDCNT1

 +2        WRITE !,"Please wait while I build the list..."

 +3        KILL ^TMP("SEL",$JOB),^TMP("SELIDX",$JOB),IBDFHDR

           DO KILL^VALM10()

 +4        SET (IBDCNT,IBDCNT1,VALMCNT)=0

 +5        SET IBDLSTNM=$PIECE(^IBE(357.2,IBLIST,0),"^",1)

           DO INTER

           Begin DoDot:1

 +6            SET IBLSNODE=$GET(^IBE(357.2,IBLIST,0))

 +7            IF $DATA(IBDFAR)

                   FOR IBDFX=0:0

                       SET IBDFX=$ORDER(@(IBDFAR_"("_IBDFX_")"))

                       IF 'IBDFX

                           QUIT 

                       SET IBDFARR=$GET(@(IBDFAR_"("_IBDFX_")"))

                       IF $PIECE(IBDFARR,"^",1)=""

                           DO HEADER

                       IF $PIECE(IBDFARR,"^",1)]""

                           DO SETARR

           End DoDot:1

 +8        IF $$LSTDESCR^IBDFU1(.IBLIST)

               QUIT 1

 +9        SET IBRTN=IBLIST("RTN")

 +10       DO RTNDSCR^IBDFU1B(.IBRTN)

 +11       IF '$DATA(^TMP("SEL",$JOB))

               DO NUL

 +12       QUIT 

 +13      ;

SETARR    ;  -- Set up Listman array

 +1        NEW IBDFNODE

 +2        WRITE "."

 +3        SET IBDFNODE=IBDFARR

 +4        SET IBDFSEL=$PIECE(IBDFNODE,"^",4)

 +5        SET IBDCNT1=IBDCNT1+1

 +6        SET IBDCNT=IBDCNT+1

           SET VALMCNT=VALMCNT+1

 +7        SET X=""

 +8        SET IBDFVAL=$JUSTIFY(IBDCNT1_")",5)

 +9        SET X=$$SETSTR^VALM1(IBDFVAL,X,1,5)

 +10       SET IBDFVAL=$PIECE(IBDFNODE,"^",1)

 +11       SET X=$$SETSTR^VALM1(IBDFVAL,X,7,7)

 +12       SET IBDFVAL=$PIECE(IBDFNODE,"^",6)

 +13       SET X=$$SETSTR^VALM1(IBDFVAL,X,16,5)

 +14       SET IBDFVAL=$PIECE(IBDFNODE,"^",2)

 +15       SET X=$$SETSTR^VALM1(IBDFVAL,X,23,40)

 +16       SET IBDFVAL=$PIECE(^IBE(357.4,$PIECE(IBDFNODE,"^",5),0),"^",1)

 +17       SET X=$$SETSTR^VALM1(IBDFVAL,X,64,15)

 +18       IF $DATA(^IBE(357.3,$PIECE(IBDFNODE,"^",4),2))

               Begin DoDot:1

 +19               SET IBDFVAL=$PIECE(^IBE(357.3,$PIECE(IBDFNODE,"^",4),2),"^")

 +20               SET X=$$SETSTR^VALM1(IBDFVAL,X,81,26)

 +21               SET IBDFVAL=$PIECE(^IBE(357.3,$PIECE(IBDFNODE,"^",4),2),"^",2)

 +22               IF $DATA(^LEX(757.01))

                       SET IBDFVAL=$PIECE($GET(^LEX(757.01,+IBDFVAL,0)),"^")

 +23              IF '$TEST

                       SET IBDFVAL=$PIECE($GET(^GMP(757.01,+IBDFVAL,0)),"^")

 +24               SET X=$$SETSTR^VALM1(IBDFVAL,X,109,23)

               End DoDot:1

TMP       ; -- Set up TMP Array

 +1        SET ^TMP("SEL",$JOB,IBDCNT,0)=X

           SET ^TMP("SEL",$JOB,"IDX",VALMCNT,IBDCNT1)=IBDFSEL

 +2       ;_"^"_IBDFX_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",5)_"^"_$P(IBDFTMP,"^",1)_"^"_$P(IBDFTMP,"^",2)

           SET ^TMP("SELIDX",$JOB,IBDCNT1)=VALMCNT_"^"_$PIECE(IBDFARR,"^",3)_"^"_$PIECE(IBDFARR,"^",4)_"^"_$PIECE(IBDFARR,"^",5)

 +3        QUIT 

HEADER    ;  -- Set up header line for the display

 +1        SET IBDCNT1=IBDCNT1+1

 +2        SET IBDCNT=IBDCNT+1

           SET VALMCNT=VALMCNT+1

 +3        SET X=""

 +4        SET IBDVAL=$SELECT($PIECE(IBDFARR,"^",2)]"":$PIECE(IBDFARR,"^",2),1:"BLANK")

 +5        SET IBDFHDR(IBDVAL)=IBDCNT_"^"_$PIECE(IBDFARR,"^",5)

 +6        SET IBDFSEL=$PIECE(IBDFARR,"^",5)

 +7        SET X=$$SETSTR^VALM1(" ",X,1,3)

           DO TMP

 +8        SET X=""

           SET IBDCNT=IBDCNT+1

           SET VALMCNT=VALMCNT+1

 +9        SET IBDVAL=$PIECE(IBDFARR,"^",6)

 +10       SET X=$$SETSTR^VALM1(IBDVAL,X,16,5)

 +11       SET IBDVAL=$PIECE(IBDFARR,"^",2)

 +12       SET IBDVAL1=$LENGTH(IBDVAL)

           SET IBDVAL1=(80-IBDVAL1)/2

           SET IBDVAL1=IBDVAL1\1

           SET X=$$SETSTR^VALM1(" ",X,22,IBDVAL1)

 +13       SET X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25)

           DO TMP

           DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)

 +14       SET X=""

           SET IBDCNT=IBDCNT+1

           SET VALMCNT=VALMCNT+1

 +15       SET X=$$SETSTR^VALM1(" ",X,1,3)

           DO TMP

 +16       SET IBDCNT1=IBDCNT1-1

 +17       QUIT 

INTER     ;  -- Find Package interface for selection list

 +1        KILL IBARRY

           SET IBDFAR="IBARRY"

           SET IBDFINT=$PIECE($GET(^IBE(357.2,IBLIST,0)),"^",11)

           SET IBDFINT(1)=$PIECE(^IBE(357.6,IBDFINT,0),"^",1)

           DO GETLST^IBDFQSL2(IBFORM,IBBLK,IBLIST,.IBDFINT,"IBARRY",1)

 +2        QUIT 

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL IBARRY,IBDFAR,IBDFARR,IBDFHDR,IBDFINT,IBDFSEL,IBDFVAL,IBDFX,IBDLSTNM,IBDVAL,IBDVAL1,IBLIST,IBRTN,IEN,IBLSNODE,DIC,IBGRP,NODE

 +2        KILL ^TMP("SEL",$JOB),^TMP("SELIDX",$JOB)

 +3        QUIT 

 +4       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

NUL       ;  -- Null message

 +1        SET ^TMP("SEL",$JOB,1,0)=" "

           SET ^TMP("SEL",$JOB,2,0)="There are no selection lists for this block."

           SET ^TMP("SELIDX",$JOB,1)=1

           SET ^TMP("SELIDX",$JOB,2)=2

 +2        QUIT