source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFQSL1.m@ 1608

Last change on this file since 1608 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1IBDFQSL1 ;ALB/CJM/AAS/MAF - ENCOUNTER FORM - Quick selection edit (cont.);12-Jun-95
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3EN ; -- main entry point for IBDF QUICK SELECTION EDIT
4 D EN^VALM("IBDF QUICK SELECTION EDIT")
5 Q
6 ;
7HDR ; -- header code
8 S VALMHDR(1)="This screen displays the selection list for ' "_$P(^IBE(357.1,IBBLK,0),"^",1)_" '"
9 S VALMHDR(2)="on Encounter Form ' "_$P(^IBE(357,IBFORM,0),"^",1)_" '"
10 Q
11 ;
12INIT ; -- init variables and list array
13 N IBDCNT,IBDCNT1
14 W !,"Please wait while I build the list..."
15 K ^TMP("SEL",$J),^TMP("SELIDX",$J),IBDFHDR D KILL^VALM10()
16 S (IBDCNT,IBDCNT1,VALMCNT)=0
17 S IBDLSTNM=$P(^IBE(357.2,IBLIST,0),"^",1) D INTER D
18 .S IBLSNODE=$G(^IBE(357.2,IBLIST,0))
19 .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
20 Q:$$LSTDESCR^IBDFU1(.IBLIST) 1
21 S IBRTN=IBLIST("RTN")
22 D RTNDSCR^IBDFU1B(.IBRTN)
23 I '$D(^TMP("SEL",$J)) D NUL
24 Q
25 ;
26SETARR ; -- Set up Listman array
27 N IBDFNODE
28 W "."
29 S IBDFNODE=IBDFARR
30 S IBDFSEL=$P(IBDFNODE,"^",4)
31 S IBDCNT1=IBDCNT1+1
32 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
33 S X=""
34 S IBDFVAL=$J(IBDCNT1_")",5)
35 S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
36 S IBDFVAL=$P(IBDFNODE,"^",1)
37 S X=$$SETSTR^VALM1(IBDFVAL,X,7,7)
38 S IBDFVAL=$P(IBDFNODE,"^",6)
39 S X=$$SETSTR^VALM1(IBDFVAL,X,16,5)
40 S IBDFVAL=$P(IBDFNODE,"^",2)
41 S X=$$SETSTR^VALM1(IBDFVAL,X,23,40)
42 S IBDFVAL=$P(^IBE(357.4,$P(IBDFNODE,"^",5),0),"^",1)
43 S X=$$SETSTR^VALM1(IBDFVAL,X,64,15)
44 I $D(^IBE(357.3,$P(IBDFNODE,"^",4),2)) D
45 .S IBDFVAL=$P(^IBE(357.3,$P(IBDFNODE,"^",4),2),"^")
46 .S X=$$SETSTR^VALM1(IBDFVAL,X,81,26)
47 .S IBDFVAL=$P(^IBE(357.3,$P(IBDFNODE,"^",4),2),"^",2)
48 .I $D(^LEX(757.01)) S IBDFVAL=$P($G(^LEX(757.01,+IBDFVAL,0)),"^")
49 .E S IBDFVAL=$P($G(^GMP(757.01,+IBDFVAL,0)),"^")
50 .S X=$$SETSTR^VALM1(IBDFVAL,X,109,23)
51TMP ; -- Set up TMP Array
52 S ^TMP("SEL",$J,IBDCNT,0)=X,^TMP("SEL",$J,"IDX",VALMCNT,IBDCNT1)=IBDFSEL
53 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)
54 Q
55HEADER ; -- Set up header line for the display
56 S IBDCNT1=IBDCNT1+1
57 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
58 S X=""
59 S IBDVAL=$S($P(IBDFARR,"^",2)]"":$P(IBDFARR,"^",2),1:"BLANK")
60 S IBDFHDR(IBDVAL)=IBDCNT_"^"_$P(IBDFARR,"^",5)
61 S IBDFSEL=$P(IBDFARR,"^",5)
62 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP
63 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
64 S IBDVAL=$P(IBDFARR,"^",6)
65 S X=$$SETSTR^VALM1(IBDVAL,X,16,5)
66 S IBDVAL=$P(IBDFARR,"^",2)
67 S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,22,IBDVAL1)
68 S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
69 S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
70 S X=$$SETSTR^VALM1(" ",X,1,3) D TMP
71 S IBDCNT1=IBDCNT1-1
72 Q
73INTER ; -- Find Package interface for selection list
74 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)
75 Q
76HELP ; -- help code
77 S X="?" D DISP^XQORM1 W !!
78 Q
79 ;
80EXIT ; -- exit code
81 K IBARRY,IBDFAR,IBDFARR,IBDFHDR,IBDFINT,IBDFSEL,IBDFVAL,IBDFX,IBDLSTNM,IBDVAL,IBDVAL1,IBLIST,IBRTN,IEN,IBLSNODE,DIC,IBGRP,NODE
82 K ^TMP("SEL",$J),^TMP("SELIDX",$J)
83 Q
84 ;
85EXPND ; -- expand code
86 Q
87 ;
88NUL ; -- Null message
89 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
90 Q
Note: See TracBrowser for help on using the repository browser.