source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFCMP1.m@ 1361

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

initial load of WorldVistAEHR
File size: 5.5 KB
RevLine 
[613]1IBDFCMP1 ;ALB/MAF - AICS list of components on a form (cont.); 29-JUL-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4 ;
5EXP ;EXPAND
6 ; -- expand action
7 N IBI,IBAT,VALMY,IBDVALM
8 S (IBDCNT,IBDCNT1,VALMCNT)=0
9 N IBDVALM,IBDAT,VALMY
10 S VALMBCK=""
11 D FULL^VALM1 S VALMBCK="R"
12 D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDVALM=0
13 F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S IBDOBJ=$G(IBBLOCK(IBDVALM)) S (IBDCNT,IBDCNT1,VALMCNT)=0 D EN^VALM("IBDF COMPONENT EXPAND")
14 G REP
15 ;
16 ;
17INIT K ^TMP("FORMEXP",$J),^TMP("EXPIDX") D
18 .S IBDFIFN=$P(IBDOBJ,"^")
19 .F IBDNUM=0:0 S IBDNUM=$O(^TMP("FORM-OBJ",$J,IBDFIFN,IBDNUM)) Q:'IBDNUM I $P(IBDOBJ,"^",11)=$P($G(^TMP("FORM-OBJ",$J,IBDFIFN,IBDNUM)),"^",9) D
20 ..N IBDFSC,IBDFNUM,IBDFSEL,IBDFHP,IBDFMC,IBDFROW,IBDFCOL
21 ..S (IBDFSC,IBDFNUM)=0
22 ..S IBDOBJ1=$G(^TMP("FORM-OBJ",$J,IBDFIFN,IBDNUM))
23 ..S IBDF("PI")=+$P(IBDOBJ1,"^",2),IBDF("TYPE")=$P(IBDOBJ1,"^",5)
24 ..S IBDF("IEN")=+$P(IBDOBJ1,"^",6),IBDF("VITAL")=$P(IBDOBJ1,"^",7)
25 ..I $P(IBDOBJ1,"^",5)="LIST" D ;SELECTION LIST
26 ...S IBDFSEL=$P(^IBE(357.2,$P(IBDOBJ1,"^",6),0),"^")
27 ...S IBDFSNOD=$O(^IBE(357.2,$P(IBDOBJ1,"^",6),1,0)) S IBDFNODE=$G(^IBE(357.2,$P(IBDOBJ1,"^",6),1,+IBDFSNOD,0)) S IBDFSEL=IBDFSEL_"^"_$P(IBDFNODE,"^",4)_"^"_$P(IBDFNODE,"^",3) S IBDFROW=4,IBDFCOL=5 D SETUP(IBDFSEL,IBDFROW,IBDFCOL)
28 ...F S IBDFSC=$O(^IBE(357.2,IBDF("IEN"),2,"B",IBDFSC)) Q:'IBDFSC F S IBDFNUM=$O(^IBE(357.2,IBDF("IEN"),2,"B",IBDFSC,IBDFNUM)) Q:'IBDFNUM S IBDFSEL=$G(^IBE(357.2,IBDF("IEN"),2,IBDFNUM,0)) D SETUP1(IBDFSEL)
29 ..I $P(IBDOBJ1,"^",5)="MC" D ;MULTIPLE CHOICE
30 ...S IBDFMC=$G(^IBE(357.93,IBDF("IEN"),0)) S IBDFROW=4,IBDFCOL=3 D SETUP(IBDFMC,IBDFROW,IBDFCOL)
31 ..I $P(IBDOBJ1,"^",5)="HP" D ;HAND PRINT FIELD
32 ...S IBDFHP=$G(^IBE(359.94,IBDF("IEN"),0)) S IBDFROW=4,IBDFCOL=3 D SETUP(IBDFHP,IBDFROW,IBDFCOL)
33 ..I $P(IBDOBJ1,"^",5)="DF" D ;DATA FIELDS
34 ...S IBDFDF=$G(^IBE(357.5,IBDF("IEN"),0)) S IBDFROW=11,IBDFCOL=10 D SETUP(IBDFDF,IBDFROW,IBDFCOL)
35 ..I $P(IBDOBJ1,"^",5)="FL" D ;FORM LINE
36 ...S IBDFFL=$G(^IBE(357.7,IBDF("IEN"),0)) S IBDFROW=3,IBDFCOL=2 D SETUP(IBDFFL,IBDFROW,IBDFCOL)
37 ..I $P(IBDOBJ1,"^",5)="TA" D ;TEXT AREA
38 ...S IBDFTA=$G(^IBE(357.8,IBDF("IEN"),0)) S IBDFROW=4,IBDFCOL=3 D SETUP(IBDFTA,IBDFROW,IBDFCOL)
39 Q
40 ;
41 ;
42REP ; -- Redisplay initial screen
43 S IBDFIFN=$S('$D(IBDFIFN):+$P(IBDOBJ,"^"),1:IBDFIFN) D INIT1^IBDFCMP S VALMBCK="R" Q
44 Q
45 ;
46 ;
47SETUP(IBOBJECT,IBROW,IBCOL) ; -- Setting up the data for list manager
48 S IBDCNT1=IBDCNT1+1
49 S X=""
50 S X=$$SETSTR^VALM1(X,X,1,80) D TMP
51 S X="",X=$P(IBOBJECT,"^")
52 S X=$$SETSTR^VALM1(X,X,1,25)
53 S IBDVAL=$S($P(IBDOBJ1,"^",5)]"":$P(IBDOBJ1,"^",5),1:"")
54 S X=$$SETSTR^VALM1(IBDVAL,X,30,10)
55 S IBDVAL=$S($P(IBOBJECT,"^",IBROW):$P(IBOBJECT,"^",IBROW)+1,$P(IBOBJECT,"^",IBROW)=0:1,1:"N/A")
56 S X=$$SETSTR^VALM1($J(IBDVAL,3),X,48,6)
57 S IBDVAL=$S($P(IBOBJECT,"^",IBCOL):$P(IBOBJECT,"^",IBCOL)+1,$P(IBOBJECT,"^",IBCOL)=0:1,1:"N/A")
58 S X=$$SETSTR^VALM1($J(IBDVAL,4),X,58,5)
59 ;D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
60 I X]"",$P(IBDOBJ1,"^",5)="LIST" D
61 .S IBDVAL=$S($P(^IBE(357.2,IBDF("IEN"),0),"^",7):$P(^IBE(357.2,IBDF("IEN"),0),"^",7),1:"N/A")
62 .S IBDVAL=$J($S(IBDVAL=1:"1 Space",IBDVAL=2:"2 Spaces",IBDVAL=3:"LINE",IBDVAL=4:"Sp/Ln/Sp",1:"N/A"),9)
63 .S X=$$SETSTR^VALM1(IBDVAL,X,71,9)
64 .D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
65 .S X="",X=$$SETSTR^VALM1(X,X,1,80) D TMP
66 .S IBDVAL=" "_"Subcolumn"_" "_"Type"_" "_"Data"_" "_"Width"_" "_"Qualifier"_" "_"Rule"_" "_"Edit"
67 .S X="",X=$$SETSTR^VALM1(IBDVAL,X,1,80) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
68 I $P(IBDOBJ1,"^",5)'="LIST" D
69 .D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
70 Q
71SETUP1(IBOBJECT) ; -- Setup of the subcolumn info for the Selection list
72 S X=""
73 S X=$$SETSTR^VALM1($P(IBOBJECT,"^"),X,8,2)
74 S IBDVAL=$S($P(IBOBJECT,"^",4)]"":$P(IBOBJECT,"^",4),1:"")
75 S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL=1:"TEXT",IBDVAL=2:"MARKING",1:"")),10)
76 S X=$$SETSTR^VALM1(IBDVAL,X,11,10)
77 S IBDVAL=$S($P(IBOBJECT,"^",5):$P(IBOBJECT,"^",5),1:"")
78 S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL=1:"CODE",IBDVAL=2:"SHORT NAME",IBDVAL=3:"DESCRIP.",1:"N/A")),10)
79 S X=$$SETSTR^VALM1(IBDVAL,X,25,10)
80 S IBDVAL=$S($P(IBOBJECT,"^",3)]"":$P(IBOBJECT,"^",3),1:"")
81 S X=$$SETSTR^VALM1($J(IBDVAL,3),X,40,3)
82 S IBDVAL=$S($P(IBOBJECT,"^",3)]"":$P(IBOBJECT,"^",3),1:"")
83 S IBDVAL=$S($P(IBOBJECT,"^",9):$P(IBOBJECT,"^",9),1:"")
84 S IBDVAL=$P($G(^IBD(357.98,+IBDVAL,0)),"^",3)
85 S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL]"":IBDVAL,1:"N/A")),10)
86 S X=$$SETSTR^VALM1(IBDVAL,X,47,10)
87 S IBDVAL=$S($P(IBOBJECT,"^",10):$P(IBOBJECT,"^",10),1:"")
88 S IBDVAL=$J($$LOWER^VALM1($S(IBDVAL=0:"ANY NUMBER",IBDVAL=1:"ONLY 1",IBDVAL=2:"AT MOST 1",IBDVAL=3:"AT LEAST 1",1:"N/A")),10)
89 S X=$$SETSTR^VALM1(IBDVAL,X,59,10)
90 ;I $P(IBDOBJ1,"^",5)="LIST" D
91 ;S IBDVAL=$S($P(^IBE(357.2,IBDF("IEN"),0),"^",7):$P(^IBE(357.2,IBDF("IEN"),0),"^",7),1:"N/A")
92 ;S IBDVAL=$S(IBDVAL=1:"1 S",IBDVAL=2:"2 S",IBDVAL=3:"LIN",IBDVAL=4:"SLS",1:"N/A")
93 S IBDVAL=$S($P(IBOBJECT,"^",7)=1:"Yes",1:"No")
94 S X=$$SETSTR^VALM1($J(IBDVAL,3),X,77,3)
95 D TMP
96 Q
97 ;
98 ;
99TMP ; -- Set up Array
100 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
101 S ^TMP("FORMEXP",$J,IBDCNT,0)=X,^TMP("FORMEXP",$J,"IDX",VALMCNT,IBDCNT1)=""
102 S ^TMP("EXPIDX",$J,IBDCNT)=VALMCNT ;_"^"_IBDFIFN_"^"_IBDF("BLK")
103 Q
104 ;
105 ;
106HDR ; -- print patient header
107 S X=""
108 S X=" Form Name: "_$E($P($G(^IBE(357,IBDFIFN,0)),"^"),1,25)
109 S VALMHDR(1)=X
110 S X=" Block Name: "_$E($P($G(^IBE(357.1,+$P(IBDOBJ,"^",11),0)),"^"),1,25)
111 S VALMHDR(2)=X
112 Q
113 ;
114 ;
115EXIT ; -- Exit code
116 K ^TMP("FORMEXP",$J),^TMP("EXPIDX")
117 Q
118HELP ; -- help code
119 S X="?" D DISP^XQORM1 W !!
120 Q
Note: See TracBrowser for help on using the repository browser.