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
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
+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
