source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE3.m@ 1708

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1IBDFDE3 ;ALB/AAS - AICS Manual Data Entry, process handprint fields ; 24-FEB-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4% G ^IBDFDE
5 ;
6HNDPR(RESULT,IBDF) ; -- Procedure
7 ; -- Manual Data entry routine for Hand Print Fields
8 ; Input : Result := call by reference, used to output results
9 ; IBDF("IEN") := pointer to hand print file (359.94)
10 ; IBDF("PI") := pointer to input package interface
11 ; IBDF("DFN") := pointer to patient
12 ; IBDF("CLINIC") := pointer to hospital location
13 ;
14 ; output: Result(n) $p1 := pointer to package interface
15 ; $p2 := input value (validated user input)
16 ; $p3 := null
17 ; $p4 := null
18 ; $p5 := null
19 ; $p6 := measurement type for vitals
20 ; $p7 := ien in handprint file
21 ; $p8 := vital type (name from 359.1)
22 ; $P9 := Units (for Vitals)
23 ; ibdpi(package interface, qlfr or n) := result(n)
24 ; $P13 := number of the selection
25 ;
26 N I,J,X,Y,ANS,DISPTXT,HDR,DIR,DIRUT,DUOUT,DTOUT,IBDX,QLFR,CHOICE,OVER,IBDPRE
27 S (IBQUIT,OVER)=0,(ANS,QLFR)=""
28 D OBJLST^IBDFRPC1(.CHOICE,.IBDF)
29 I +CHOICE(0)<1 G HPQ
30 S IBDASK=$P(CHOICE(1),"^")_" "
31 I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
32 I $P($G(^IBE(357.6,+IBDF("PI"),0)),"^")["INPUT VITALS" S QLFR=$P(CHOICE(1),"^",5)
33 ;
34OVER ;
35 K X,Y,DIR,DIRUT,DUOUT,DTOUT
36 S OVER=0
37 S DIR("?")="Enter the value on the form, or enter Return if there is no value"
38 S DIR(0)="FOA^2:"_$P(CHOICE(1),"^",3)
39 I $G(QLFR)'="",$P($G(IBDPI(IBDF("PI"),QLFR)),"^",2)'="" S DIR("B")=$P($G(IBDPI(IBDF("PI"),QLFR)),"^",2)
40 S DIR("A")=$P(CHOICE(1),"^")_" "
41 I $D(IBDF("ASKDATE")) S Y=$$ASKDT^IBDFDE0(DIR("A"),$S($D(DIR("B")):DIR("B"),1:$G(IBDF("DEFLT"))),"",IBDF("APPT")) G REV
42 D ^DIR
43REV I $G(IBDREDIT),$G(DIR("B"))'="" S IBDPRE=DIR("B") G:Y=$G(DIR("B")) HPQ
44 S ANS=$$UP^XLFSTR(Y)
45 K DIR
46 I $G(IBDREDIT),$G(IBDPRE)'="",ANS="" D DELETE W " Deleted!" G HPQ
47 I ANS="" G HPQ
48 I ANS["^",ANS'="^" D G HPOVER
49 .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
50 .I "????"[GOTO X "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX" S OVER=1 Q
51 .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
52 .I X'="",X[GOTO W $E(X,$L(GOTO)+1,$L(X)) S IBDF("GOTO")=+$O(^TMP("IBD-ASK",$J,IBDFMIEN,X,""))-1,IBDREDIT=1 Q
53 .S IBQUIT=1
54 I $D(DIRUT) S IBQUIT=1 G HPQ
55 ;
56VITALS ; -- if vitals, validate input
57 S OVER=0
58 I $G(QLFR)'="" D I OVER G HPOVER
59 .I $L($T(RATECHK^GMRVPCE0)) D Q
60 ..S OVER='$$RATECHK^GMRVPCE0(QLFR,ANS,$P(CHOICE(1),"^",6))
61 ..Q:'OVER
62 ..D HELP^GMRVPCE0(QLFR,"HELP")
63 ..W ! S IBDX="" F S IBDX=$O(HELP(IBDX)) Q:IBDX="" W !,HELP(IBDX)
64 ..W ! K ANS,HELP
65 .I $L($T(@(QLFR))) D @QLFR Q
66 ;
67 ; -- delete old answer
68 I $G(IBDREDIT),$G(IBDPRE)'="",$G(IBDPRE)'=ANS D DELETE
69 ;
70 I ANS'="" D
71 .S RESULT(0)=$G(RESULT(0))+1
72 .S RESULT(RESULT(0))=+IBDF("PI")_"^"_ANS_"^^^^"_QLFR_"^"_$G(IBDF("IEN"))_"^"_$G(IBDF("VITAL"))_"^"_$P(CHOICE(1),"^",4)
73 .S IBDPI(IBDF("PI"),$S($G(QLFR)'="":QLFR,1:RESULT(0)))=IBDSEL(RESULT(0))
74 .S $P(IBDPI(IBDF("PI"),$S($G(QLFR)'="":QLFR,1:RESULT(0))),"^",13)=RESULT(0)
75 ;
76HPOVER G:OVER OVER
77HPQ Q
78 ;
79DELETE ; -- delete old answer if changed
80 Q:'$G(IBDREDIT)!(ANS=$G(IBDPRE))
81 S SEL=+$P($G(IBDPI(IBDF("PI"),QLFR)),"^",13) Q:'SEL
82 K IBDPI(IBDF("PI"),QLFR),RESULT(SEL)
83 I $G(RESULT(0))=1 S RESULT(0)=0
84 Q
85 ;
86BP ; -- validate blood pressure
87 N D,S
88 I ANS'?2.3N1"/"2.3N S OVER=1 K ANS G BPQ
89 S S=$P(ANS,"/"),D=$P(ANS,"/",2)
90 I D<20!(D>200)!(S<20)!(S>275) K ANS S OVER=1
91 I S'>D K ANS S OVER=1
92BPQ I OVER W !,"Invalid format. Enter as SYSTOLIC/DIASTOLIC (120/80). SYSTOLIC must be",!,"between 20 and 275. DIASTOLIC must be between 20 and 200. SYSTOLIC must be",!,"greater than DIASTOLIC.",!
93 Q
94 ;
95WT ; -- validate body weight
96 I ANS'?1.3N.1".".1N!(ANS<2)!(ANS>750)!(+ANS'=ANS) K ANS S OVER=1
97WTQ I OVER W !,"Enter a body weight, 1 decimal place allowed, between 2 and 750 lbs.",!
98 Q
99 ;
100HT ; --validate body height
101 I ANS'?2N.1".".1N!(ANS<10)!(ANS>80) K ANS S OVER=1
102 I OVER W !,"Enter the body height in inches, 1 decimal place allowed, between 10 and 80.",!
103 Q
104 ;
105AG ; -- validate adominal girth
106 I +ANS'=ANS!(ANS?.E1"."1N.N)!(ANS<10)!(ANS>750) K ANS S OVER=1
107 I OVER W !,"Enter the abdominal girth in inches, no decimal places, between 10 and 750.",!
108 Q
109 ;
110AUD ; -- validate audiometry
111 N %AUI,%AUX
112 I $L(ANS,"/")'=17 K ANS S OVER=1
113 F %AUI=1:1:16 S %AUX=$P(X,"/",%AUI) I %AUX'="" I %AUX'?1.3N!(+%AUX>110) K ANS S OVER=1
114 I OVER W !,"Enter 8 readings for right ear followed by 8 readings for left ear,",!,"all followed by slashes (/). Values must be between 0 and 110.",!,"EXAMPLE: 100/100/100/95/90/90/85/80/105/105/105/105/100/100/95/90/",!
115 Q
116 ;
117TMP ; -- validate temperature
118 I ANS'?2.3N.1".".1N!(ANS<94)!(ANS>109.9)!(+ANS'=ANS) K ANS S OVER=1
119 I OVER W !,"Enter the body temperature in degrees fahrenheit, must be between 94 and 109.9.",!
120 Q
121 ;
122FT ; -- validate fetal heart tones
123 I ANS'=+ANS!(ANS<50)!(ANS>250)!(ANS?.E1"."1N.N) K ANS S OVER=1
124 I OVER W !,"Enter Fetal Heart Tone. Must be in the range 50 -250.",!
125 Q
126 ;
127FH ; -- validate fundal height
128 I ANS'=+ANS!(ANS<10)!(ANS>250)!(ANS?.E1"."1N.N) K ANS S OVER=1
129 I OVER W !,"Enter a fundal Height. Must be in the range 10 - 50",!
130 Q
131 ;
132HC ; -- validate head circumference
133 I ANS'=+ANS!(ANS<10)!(ANS>30)!(ANS?.E1"."3N.N) K ANS S OVER=1
134 I OVER W !,"To enter head circumference in inches, enter the inches",!,"and decimal. Must be 10 - 30 inches and the fractional decimal part must",!,"be a multiple of 1/8 (.125)",!
135 Q
136 ;
137HE ; -- validate hearing
138 S ANS=$$UP^XLFSTR($E(ANS))
139 I "AN"'[ANS K ANS S OVER=1
140 I OVER W !,"Enter 'A' for abnormal, or 'N' for Normal.",!
141 Q
142 ;
143PU ; -- validate pulse
144 I ANS'?1.3N!(ANS<30)!(ANS>250) K ANS S OVER=1
145 I OVER W !,"Enter the patients 1 minute pulse, enter a number between 30 and 250.",!
146 Q
147 ;
148RS ; -- validate respirations
149 I ANS'?1.2N!(ANS<8)!(ANS>90) K ANS S OVER=1
150 I OVER W !,"Enter the patients 1 minute number of resperations, enter a number between 8 and 90.",!
151 Q
152 ;
153TON ; -- validate tonometry
154 N AUTONR,AUTONL
155 I $L(ANS)>7!($L(ANS)<2)!'((ANS?.1"R"1.2N1"/")!(ANS?1"/".1"L"1.2N)!(ANS?.1"R"1.2N1"/".1"L"1.2N)) K ANS S OVER=1
156 S AUTONR=$P(ANS,"/",1) S:AUTONR?1"R".N AUTONR=$E(AUTONR,2,10)
157 S AUTONL=$P(ANS,"/",2) S:AUTONL?1"L".N AUTONL=$E(AUTONL,2,10)
158 I AUTONR'="" I AUTONR<0!(AUTONR>80) K ANS S OVER=1
159 I AUTONL'="" I AUTONL<0!(AUTONL>80) K ANS S OVER=1
160TONX I OVER W !,"Enter a reading for the RIGHT eye, followed by a SLASH, followed",!,"by the reading for the LEFT eye. The SLASH is required. Readings can be",!,"between 0 and 80. Examples: 18/18, /20, 18/, 10/13"
161 Q
162 ;
163VC ; -- validate vision corrected
164 ; same input as uncorrected
165VU ; -- validate vision uncorrected
166 I $L(ANS)>7!($L(ANS)<2)!'((ANS?2.3N)!(ANS?1"/"2.3N)!(ANS?2.3N1"/"2.3N)) K ANS S OVER=1
167 I $P(ANS,"/",1)'="" I $P(ANS,"/",1)<10!($P(ANS,"/",1)>999) K ANS S OVER=1
168 I $P(ANS,"/",2)'="" I $P(ANS,"/",2)<10!($P(ANS,"/",2)>999) K ANS S OVER=1
169 I OVER W !,"Enter denominators only. The 20/ is assumed. Enter right eye",!,"/ left eye in form n/n (20/20). If right eye only enter n (20).",!,"If left eye only enter /n (/20). Must be between 10 and 999."
170 Q
Note: See TracBrowser for help on using the repository browser.