AUPNVMSR ; IHS/CMI/LAB - EDITS FOR AUPNVMSR (MEASUREMENTS:9000010.04) 24-MAY-1993 ; 30 Sep 2010 2:16 PM
;;2.0;IHS PCC SUITE;**2,5,7,8,10,15,16,17,20**;MAY 14, 2009;Build 25
;;
;;BJPC patch 1
;; - PF changed to 50-1000
;; - added ASFD
;; - added BPF - Best Peak Flow
;;
;S AUPNMTYP=$P(^AUPNVMSR(DA,0),U,1),AUPNMTYP=$P(^AUTTMSR(AUPNMTYP,0),U,1)
;I $T(@AUPNMTYP)="" Q
;D @AUPNMTYP
NEW AUPNMTYP
S AUPNMTYP=$P(^AUPNVMSR(DA,0),U,1)
X ^AUTTMSR(AUPNMTYP,12)
K AUPNMTYP
Q
;
BHM ;PEP - called from BH measurements dd
NEW AUPNMTYP
S AUPNMTYP=$P(^AMHRMSR(DA,0),U,1)
X ^AUTTMSR(AUPNMTYP,12)
K AUPNMTYP
Q
;S AUPNMTYP=$P(^AMHRMSR(DA,0),U,1),AUPNMTYP=$P(^AUTTMSR(AUPNMTYP,0),U,1)
;I $T(@AUPNMTYP)="" Q
;D @AUPNMTYP
;K AUPNMTYP
Q
;
AUD ; (AUDIOMETRY)
NEW %AUI,%AUX
I $L(X,"/")'=17 K X Q
F %AUI=1:1:16 S %AUX=$P(X,"/",%AUI) I %AUX'="" I %AUX'?1.3N!(+%AUX>110) K X Q
Q
AKBP ;EP - ANKLE BLOOD PRESSURE
BP ;EP (BLOOD PRESSURE)
NEW AUPNBPS,AUPNBPD
I $L(X)>7!($L(X)<5)!'(X?2.3N1"/"2.3N) K X Q
S AUPNBPS=+$P(X,"/",1),AUPNBPD=+$P(X,"/",2)
I AUPNBPS<20!(AUPNBPS>275) K X G BPX
I AUPNBPD<20!(AUPNBPD>200) K X G BPX
I AUPNBPS'>AUPNBPD K X G BPX
S X=AUPNBPS_"/"_AUPNBPD
BPX ;
Q
CXD ;;CERVIX DILATATION
K:X<0!(X>10) X
Q
ED ; (EDEMA)
I $L(X)>2!($L(X)<1) K X Q
I +X>4 K X Q
Q:X=0
I X'?1N1"+" K X Q
Q
EF ;EFFACEMENT
K:X<0!(X>100) X
Q
HC ; (HEAD CIRCUMFERENCE)
D:X?.E.A.E MHT
Q:'$D(X)
D HTHCC
S:$P(X,".",2)?4N.N X=X+.0005,X=$P(X,".",1)_"."_$E($P(X,".",2),1,3)
S X=+X
Q:'$D(X)
K:+X'=X!(X>30)!(X<10)!(X?.E1"."4N.N) X
Q:'$D(X)
;K:X-(X\1)#.125 X
Q
HE ; (HEARING)
K:X'="A"&(X'="N") X
Q
WC ; (WAIST CIRCUMFERENCE)
I X'=+X K X Q
K:+X'=X!(X>99)!(X<20)!(X?.E1"."3N.N) X
Q
PA ;EP (PAIN)
I X'=+X K X Q
K:(X<0)!(X>10) X
Q
NSST ;EP (NSST)
I X'=+X K X Q
K:(X<0)!(X>42) X
Q
FI24 ;EP (PAIN)
I X'=+X K X Q
K:(X<0)!(X>10000) X
Q
FO24 ;EP (PAIN)
I X'=+X K X Q
K:(X<0)!(X>10000) X
Q
FBPN ;EP (PAIN)
I X'=+X K X Q
K:(X<-10000)!(X>10000) X
Q
HT ; (HEIGHT)
D:X?.E.A.E MHT
Q:'$D(X)
D HTHCC
S:$P(X,".",2)?4N.N X=X+.0005,X=$P(X,".",1)_"."_$E($P(X,".",2),1,3)
S X=+X
Q:'$D(X)
K:+X'=X!(X>90)!(X<10)!(X?.E1"."4N.N) X
Q:'$D(X)
;K:X-(X\1)#.125 X
Q
HTHCC Q:X'["/"
Q:X'?2N1" "1N1"/"1N
S X=$P(X," ",1)_+("."_($P($P(X," ",2),"/",1)*1000\$P($P(X," ",2),"/",2)))
Q
;
MHT ;
NEW AUPNC,AUPNI,AUPNJ
S AUPNJ=$L(X) F AUPNI=1:1:AUPNJ S AUPNC=$E(X,AUPNI) I AUPNC?1A S AUPNC=$S(AUPNC?1L:$C($A(AUPNC)-32),1:AUPNC)
S (AUPNI,AUPNC)="" F AUPNI=1:1:AUPNJ S AUPNC=$E(X,AUPNI) Q:"C"[AUPNC
I AUPNC="C" D @AUPNC
K AUPNC,AUPNI,AUPNJ
Q
PR ; (PRESENTATION)
NEW AUTFN,AUTVAL
I X="U" S X="UNKNOWN"
S AUTVAL=X,AUTFN=9999999.87
S %=$$PRLK(AUTFN,AUTVAL)
I %="" K X Q
S X=%
Q:$D(ZTQUEUED)
Q:$D(APCDATMP) ;don't talk if in APCDALVR mode
W " ",X
Q
PRLK(AUTFN,AUTVAL) ;
NEW AUTVALI
S AUTVALI=""
D EN^XBNEW("DIC^AUPNVMSR","AUTFN,AUTVAL,AUTVALI")
Q AUTVALI
PU ;EP (PULSE)
K:+X'=X!(X>250)!(X<30)!(X?.E1"."1N.N) X
Q
SN ;STATION
K:X<-6!(X>4) X
Q
TMP ; (TEMPERATURE)
K:+X'=X!(X>120)!(X<70)!(X?.E1"."2N.N) X
Q
TON ; (TONOMETRY)
NEW %AURR,%AURP,%AURI,%AULR,%AULP,%AULI
I $L(X)>5!($L(X)<3)!'((X?1.3N1"/")!(X?1"/"1.3N)!(X?1.3N1"/"1.3N)) K X Q
I $P(X,"/",1)'="" I $P(X,"/",1)<0!($P(X,"/",1)>80) K X Q
I $P(X,"/",2)'="" I $P(X,"/",2)<0!($P(X,"/",2)>80) K X Q
I $P(X,"/",1)]"" S X="R"_X
I $P(X,"/",2)]"" S X=$P(X,"/",1)_"/L"_$P(X,"/",2)
TONX ;
K %AURR,%AURP,%AURI,%AULR,%AULP,%AULI
Q
VC ; (VISION CORRECTED)
VU ; (VISION UNCORRECTED)
I $D(DIFGLINE) Q ;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002 - do not do edit if in filegrams (mfi)
I $L(X)>11!($L(X)<2) K X Q
I '((X?2.3AN)!(X?1"/"2.3AN)!(X?2.3AN1"/"2.3AN)!(X?2"/"2.3AN)!(X?1"/"2.3AN1"/"2.3N)!(X?2.3AN1"/"2.3AN1"/"2.3AN)) K X Q
I $P(X,"/",1)'="",+($P(X,"/",1)) I $P(X,"/",1)<10!($P(X,"/",1)>999) K X Q
I $P(X,"/",1)'="",'($P(X,"/",1)) I $P(X,"/")'="HM"&($P(X,"/")'="LP")&($P(X,"/")'="NLP") K X Q
I $P(X,"/",2)'="",+($P(X,"/",2)) I $P(X,"/",2)<10!($P(X,"/",2)>999) K X Q
I $P(X,"/",2)'="",'($P(X,"/",2)) I $P(X,"/",2)'="HM"&($P(X,"/",2)'="LP")&($P(X,"/",2)'="NLP") K X Q ;IHS/CMI/LAB -
I $P(X,"/",3)'="",+($P(X,"/",3)) I $P(X,"/",3)<10!($P(X,"/",3)>999) K X Q
I $P(X,"/",3)'="",'($P(X,"/",3)) I $P(X,"/",3)'="HM"&($P(X,"/",3)'="LP")&($P(X,"/",3)'="NLP") K X Q ;IHS/CMI/LAB - patch 17
Q
WT ;EP (WEIGHT)
D:X?.E.A.E MWT
Q:'$D(X)
D WTC
S:$P(X,".",2)?5N.N X=X+.00005,X=$P(X,".",1)_"."_$E($P(X,".",2),1,4)
S X=+X
Q:'$D(X)
K:+X'=X!(X>1000)!(X<2)!(X?.E1"."5N.N) X
Q:'$D(X)
;K:X-(X\1)#.0625 X
Q
WTC Q:+X=X!(X'[" ")
Q:'(X?1.3N1" "1.2N!(X?1.3N1" "1.2N1"/"1.2N))
I X'["/" Q:+$P(X," ",2)>16 S X=+X+(+$P(X," ",2)/16) Q
Q:+$P($P(X," ",2),"/",1)'<+$P($P(X," ",2),"/",2)
S X=+X+((+$P(X," ",2)/$P($P(X," ",2),"/",2)))
Q
;
MWT ;
NEW AUPNC,AUPNI,AUPNJ
S AUPNJ=$L(X) F AUPNI=1:1:AUPNJ S AUPNC=$E(X,AUPNI) I AUPNC?1A S AUPNC=$S(AUPNC?1L:$C($A(AUPNC)-32),1:AUPNC)
S (AUPNI,AUPNC)="" F AUPNI=1:1:AUPNJ S AUPNC=$E(X,AUPNI) Q:"GK"[AUPNC
I "GK"[AUPNC D @AUPNC
K AUPNC,AUPNI,AUPNJ
Q
MWTC ;
Q:+X=X!(X'[" ")!(X'["/")
K:'(X?1.6N1" "1.2N1"/"1.2N) X
Q:'$D(X)
S X=+X+((+$P(X," ",2)/$P($P(X," ",2),"/",2)))
Q
K ;
I X["/" S X=$P(X,AUPNC,1) D MWTC
Q:'$D(X)
S X=+X
S X=(X*2.2046226)
Q
G ;
I X["/" S X=$P(X,AUPNC,1) D MWTC
Q:'$D(X)
S X=+X
S X=(X*.0022046226)
Q
C ;
I X["/" S X=$P(X,AUPNC,1) D MWTC
Q:'$D(X)
S X=+X
S X=(X*.393701)
Q
AG ; (ABDOMINAL GIRTH)
K:+X'=X!(X>250)!(X<10)!(X?.E1"."3N.N) X
Q
FH ; Fundal Height
K:+X'=X!(X>100)!(X<0)!(X?.E1"."3N.N) X
Q
FT ; Fetal Heart Tones
K:+X'=X!(X>400)!(X<0)!(X?.E1"."1N.N) X
Q
RS ;EP
;IHS/CMI/LAB - up'ed value to 100 pre Madonna Long aberdeen
I X'?1.3N!(X<0)!(X>140) K X Q
Q
;
O2 ;EP called from input template
I X'?1.3N!(X<50)!(X>100) K X
Q
PF ;EP called from input template
I X'?1.4N!(X<50)!(X>1000) K X ;IHS/CMI/LAB 1-25-08; values 5-1000 CR #85
Q
BS ;EP -per dina in billings
Q
CEF ;EP called from input tx, per Terry Cullen 3-17-04
Q:'$D(X)
K:(X<5)!(X>99) X
Q
ASQM ; EP - ASQ questionnaire (Mos)
I '$D(^VEN(7.14,"B",X)) K X
Q
;
PHQ2 ; EP - PHQ2
I X'?1N K X Q
I X'=+X K X Q
K:(X<0)!(X>6) X
Q
;
PHQ9 ; EP - PHQ9
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>27) X
Q
PHQT ; EP - PHQT
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>27) X
Q
;
AUDT ; EP - AUDT
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>40) X
Q
;
AUDC ; EP - AUDT
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>12) X
Q
;
CRFT ; EP - CRFT
I X'?1N K X Q
I X'=+X K X Q
K:(X<0)!(X>6) X
Q
;
ASFD ; EP - ASFD
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>14) X
Q
;
ADM ; EP - ADM
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>14) X
Q
;
BPF ;EP called from input template
I X'?1.4N!(X<50)!(X>1000) K X ;IHS/CMI/LAB 1-25-08; values 5-1000 CR #85
Q
;
FEF ;EP - FEF 25-75
S X=$$STRIP^XLFSTR(X," ")
I X'=+X K X Q
K:(X<0)!(X>150) X
Q
;
FEV1 ;EP - FEV1
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>10) X
Q
;
FV1P ;EP - FEV1 %
S X=$$STRIP^XLFSTR(X," ")
;I X'?1.3N!(X'?1.3N1"%") K X
I X'=+X K X Q
K:(X<0)!(X>150) X
Q
;
FVC ;EP - forced vital capacity
I X'?1.2N K X Q
I X'=+X K X Q
K:(X<0)!(X>10) X
Q
;
FVCP ;EP - FEV1 %
S X=$$STRIP^XLFSTR(X," ")
I X'=+X K X Q
K:(X<0)!(X>150) X
Q
;
FVFC ;EP - FEV1/FVC
I $L(X)>11!($L(X)<2)!'(X?0.2N0.1"."0.2N1"/"0.2N0.1"."0.2N) K X Q
NEW F,S
S F=$P(X,"/",1),S=$P(X,"/",2)
I F="" K X Q
I S="" K X Q
S F=+F
S S=+S
I F<0!(F>10) K X Q
I S<0!(S>10) K X Q
Q
LKW ;EP - LKW
I X'="WELL" K X Q
Q
EGA ;EP - EGA
I X?1.2N D Q
.I +X<4 K X Q
.I +X>44 K X Q
I X'?1.2N1" "1N1"/"1"7" K X Q
NEW %
S %=$P(X," ")
I %<4 K X Q
I %>44 K X Q
S %=$E($P(X," ",2))
I %<1 K X Q
I %>6 K X Q
Q
;
ASQF ; EP - ASQ development score: FINE MOTOR
ASQG ; EP - ASQ development score: GROSS MOTOR
ASQL ; EP - ASQ development score: LANGUAGE
ASQS ; EP - ASQ development score: SOCIAL
ASQP ; EP - ASQ development score: PROBLEM SOLVING
I $P(X," ")'?1.2N K X Q
I +X#5 K X
Q
BL ;EP - called from birth length of Birth measurement file
Q:X=""
I $E(X)="C" S X=$E(X,2,9999),X=X*.3937008
I X'=+X K X Q
I X<6 K X Q
I X>30 K X Q
Q
F10R ;EP (F10R)
;For women: <1, 1, 2, 3, 4, 5, 6, 8, 11, 14, 17, 22, 27, >30
;For men: <1, 1, 2, 3, 4, 5, 6, 8, 10, 12, 16, 20, 25, >30
I X="<1" Q
I X=1 Q
I X=2 Q
I X=3 Q
I X=4 Q
I X=5 Q
I X=6 Q
I X=8 Q
I X=">30" Q
I $G(AUPNSEX)="F"!($G(SEX)="F") D Q
.I X=11 Q
.I X=14 Q
.I X=17 Q
.I X=22 Q
.I X=27 Q
.K X
I $G(AUPNSEX)="M"!($G(SEX)="M") D Q
.I X=10 Q
.I X=12 Q
.I X=16 Q
.I X=20 Q
.I X=25 Q
.K X
Q
;
OUT(IEN,VAL) ;EP called from output transform
I 'IEN Q VAL
I '$D(^AUPNVMSR(IEN,0)) Q VAL
NEW % S %=$P(^AUPNVMSR(IEN,0),U)
I $P(^AUTTMSR(%,0),U)="FEF" Q $S(VAL["%":VAL,1:VAL_"%")
I $P(^AUTTMSR(%,0),U)="FV1P" Q $S(VAL["%":VAL,1:VAL_"%")
I $P(^AUTTMSR(%,0),U)="FVCP" Q $S(VAL["%":VAL,1:VAL_"%")
I $P(^AUTTMSR(%,0),U)="F10R" Q $S(VAL["%":VAL,1:VAL_"%")
I $P(^AUTTMSR(%,0),U)="CDR" D Q VAL
.I $P(VAL,".",1)="" S VAL="0"_VAL
I $P(^AUTTMSR(%,0),U)'="VC"&($P(^AUTTMSR(%,0),U)'="VU") Q VAL
NEW X
S X=VAL
S VAL=$S($P(^AUPNVMSR(IEN,0),U,6):$P(^AUPNVMSR(IEN,0),U,6),1:"20")_"/"_$P(X,"/")_"-"_$S($P(^AUPNVMSR(IEN,0),U,6):$P(^AUPNVMSR(IEN,0),U,6),1:"20")_"/"_$P(X,"/",2) D
.S:$P(X,"/",3)]"" VAL=VAL_"-"_$S($P(^AUPNVMSR(IEN,0),U,6):$P(^AUPNVMSR(IEN,0),U,6),1:"20")_"/"_$P(X,"/",3)
Q VAL
VCVU(VAL,DEN) ;EP - CALLED FROM MEASUREMENT PANEL
NEW A
S A=$S(DEN:DEN,1:"20")_"/"_$P(VAL,"/")_"-"_$S(DEN:DEN,1:"20")_"/"_$P(VAL,"/",2) D
.S:$P(VAL,"/",3)]"" A=A_"-"_$S(DEN:DEN,1:"20")_"/"_$P(VAL,"/",3)
Q A
HELP ;EP - HELP FOR VARIOUS TYPES
D ^AUPNVMS2
Q
DIC ;EP
N X S X=AUTVAL
S DIC=$$DIC^XBDIQ1(AUTFN)
Q:'$L(DIC)
S DIC(0)="M"
D ^DIC
S:+Y>0 AUTVALI=$P(Y,U,2)
Q
;
OUTBH(IEN,VAL) ;EP called from output transform
I 'IEN Q VAL
I '$D(^AMHRMSR(IEN,0)) Q VAL
NEW % S %=$P(^AMHRMSR(IEN,0),U)
I $P(^AUTTMSR(%,0),U)'="VC"&($P(^AUTTMSR(%,0),U)'="VU") Q VAL
S VAL=$S($P(^AMHRMSR(IEN,0),U,6):$P(^AMHRMSR(IEN,0),U,6),1:"20")_"/"_$P(VAL,"/")_"-"_$S($P(^AMHRMSR(IEN,0),U,6):$P(^AMHRMSR(IEN,0),U,6),1:"20")_"/"_$P(VAL,"/",2)
Q VAL
EN1(Y,DA) ;EP - INPUT TRANSFORM FOR NAME (.01) FIELD OF QUALIFIER
; SUB-FILE OF V MEASUREMENT FILE.
; Input variables: Y is entry in 120.52 being looked up
; DA is entry in V MEASUREMENT where Qualifier data
; is being selected.
; Function value: 1 if can select this Qualifier, else 0.
;
N GMRVFXN,GMRVTYP S GMRVFXN=0
S GMRVTYP=$P($G(^AUPNVMSR(DA,0)),"^",1)
I GMRVTYP>0,$D(^GMRD(120.52,"C",GMRVTYP,+Y)) S GMRVFXN=1
Q GMRVFXN
;
AUPNVMSR ; IHS/CMI/LAB - EDITS FOR AUPNVMSR (MEASUREMENTS:9000010.04) 24-MAY-1993 ; 30 Sep 2010 2:16 PM
+1 ;;2.0;IHS PCC SUITE;**2,5,7,8,10,15,16,17,20**;MAY 14, 2009;Build 25
+2 ;;
+3 ;;BJPC patch 1
+4 ;; - PF changed to 50-1000
+5 ;; - added ASFD
+6 ;; - added BPF - Best Peak Flow
+7 ;;
+8 ;S AUPNMTYP=$P(^AUPNVMSR(DA,0),U,1),AUPNMTYP=$P(^AUTTMSR(AUPNMTYP,0),U,1)
+9 ;I $T(@AUPNMTYP)="" Q
+10 ;D @AUPNMTYP
+11 NEW AUPNMTYP
+12 SET AUPNMTYP=$PIECE(^AUPNVMSR(DA,0),U,1)
+13 XECUTE ^AUTTMSR(AUPNMTYP,12)
+14 KILL AUPNMTYP
+15 QUIT
+16 ;
BHM ;PEP - called from BH measurements dd
+1 NEW AUPNMTYP
+2 SET AUPNMTYP=$PIECE(^AMHRMSR(DA,0),U,1)
+3 XECUTE ^AUTTMSR(AUPNMTYP,12)
+4 KILL AUPNMTYP
+5 QUIT
+6 ;S AUPNMTYP=$P(^AMHRMSR(DA,0),U,1),AUPNMTYP=$P(^AUTTMSR(AUPNMTYP,0),U,1)
+7 ;I $T(@AUPNMTYP)="" Q
+8 ;D @AUPNMTYP
+9 ;K AUPNMTYP
+10 QUIT
+11 ;
AUD ; (AUDIOMETRY)
+1 NEW %AUI,%AUX
+2 IF $LENGTH(X,"/")'=17
KILL X
QUIT
+3 FOR %AUI=1:1:16
SET %AUX=$PIECE(X,"/",%AUI)
IF %AUX'=""
IF %AUX'?1.3N!(+%AUX>110)
KILL X
QUIT
+4 QUIT
AKBP ;EP - ANKLE BLOOD PRESSURE
BP ;EP (BLOOD PRESSURE)
+1 NEW AUPNBPS,AUPNBPD
+2 IF $LENGTH(X)>7!($LENGTH(X)<5)!'(X?2.3N1"/"2.3N)
KILL X
QUIT
+3 SET AUPNBPS=+$PIECE(X,"/",1)
SET AUPNBPD=+$PIECE(X,"/",2)
+4 IF AUPNBPS<20!(AUPNBPS>275)
KILL X
GOTO BPX
+5 IF AUPNBPD<20!(AUPNBPD>200)
KILL X
GOTO BPX
+6 IF AUPNBPS'>AUPNBPD
KILL X
GOTO BPX
+7 SET X=AUPNBPS_"/"_AUPNBPD
BPX ;
+1 QUIT
CXD ;;CERVIX DILATATION
+1 IF X<0!(X>10)
KILL X
+2 QUIT
ED ; (EDEMA)
+1 IF $LENGTH(X)>2!($LENGTH(X)<1)
KILL X
QUIT
+2 IF +X>4
KILL X
QUIT
+3 IF X=0
QUIT
+4 IF X'?1N1"+"
KILL X
QUIT
+5 QUIT
EF ;EFFACEMENT
+1 IF X<0!(X>100)
KILL X
+2 QUIT
HC ; (HEAD CIRCUMFERENCE)
+1 IF X?.E.A.E
DO MHT
+2 IF '$DATA(X)
QUIT
+3 DO HTHCC
+4 IF $PIECE(X,".",2)?4N.N
SET X=X+.0005
SET X=$PIECE(X,".",1)_"."_$EXTRACT($PIECE(X,".",2),1,3)
+5 SET X=+X
+6 IF '$DATA(X)
QUIT
+7 IF +X'=X!(X>30)!(X<10)!(X?.E1"."4N.N)
KILL X
+8 IF '$DATA(X)
QUIT
+9 ;K:X-(X\1)#.125 X
+10 QUIT
HE ; (HEARING)
+1 IF X'="A"&(X'="N")
KILL X
+2 QUIT
WC ; (WAIST CIRCUMFERENCE)
+1 IF X'=+X
KILL X
QUIT
+2 IF +X'=X!(X>99)!(X<20)!(X?.E1"."3N.N)
KILL X
+3 QUIT
PA ;EP (PAIN)
+1 IF X'=+X
KILL X
QUIT
+2 IF (X<0)!(X>10)
KILL X
+3 QUIT
NSST ;EP (NSST)
+1 IF X'=+X
KILL X
QUIT
+2 IF (X<0)!(X>42)
KILL X
+3 QUIT
FI24 ;EP (PAIN)
+1 IF X'=+X
KILL X
QUIT
+2 IF (X<0)!(X>10000)
KILL X
+3 QUIT
FO24 ;EP (PAIN)
+1 IF X'=+X
KILL X
QUIT
+2 IF (X<0)!(X>10000)
KILL X
+3 QUIT
FBPN ;EP (PAIN)
+1 IF X'=+X
KILL X
QUIT
+2 IF (X<-10000)!(X>10000)
KILL X
+3 QUIT
HT ; (HEIGHT)
+1 IF X?.E.A.E
DO MHT
+2 IF '$DATA(X)
QUIT
+3 DO HTHCC
+4 IF $PIECE(X,".",2)?4N.N
SET X=X+.0005
SET X=$PIECE(X,".",1)_"."_$EXTRACT($PIECE(X,".",2),1,3)
+5 SET X=+X
+6 IF '$DATA(X)
QUIT
+7 IF +X'=X!(X>90)!(X<10)!(X?.E1"."4N.N)
KILL X
+8 IF '$DATA(X)
QUIT
+9 ;K:X-(X\1)#.125 X
+10 QUIT
HTHCC IF X'["/"
QUIT
+1 IF X'?2N1" "1N1"/"1N
QUIT
+2 SET X=$PIECE(X," ",1)_+("."_($PIECE($PIECE(X," ",2),"/",1)*1000\$PIECE($PIECE(X," ",2),"/",2)))
+3 QUIT
+4 ;
MHT ;
+1 NEW AUPNC,AUPNI,AUPNJ
+2 SET AUPNJ=$LENGTH(X)
FOR AUPNI=1:1:AUPNJ
SET AUPNC=$EXTRACT(X,AUPNI)
IF AUPNC?1A
SET AUPNC=$SELECT(AUPNC?1L:$CHAR($ASCII(AUPNC)-32),1:AUPNC)
+3 SET (AUPNI,AUPNC)=""
FOR AUPNI=1:1:AUPNJ
SET AUPNC=$EXTRACT(X,AUPNI)
IF "C"[AUPNC
QUIT
+4 IF AUPNC="C"
DO @AUPNC
+5 KILL AUPNC,AUPNI,AUPNJ
+6 QUIT
PR ; (PRESENTATION)
+1 NEW AUTFN,AUTVAL
+2 IF X="U"
SET X="UNKNOWN"
+3 SET AUTVAL=X
SET AUTFN=9999999.87
+4 SET %=$$PRLK(AUTFN,AUTVAL)
+5 IF %=""
KILL X
QUIT
+6 SET X=%
+7 IF $DATA(ZTQUEUED)
QUIT
+8 ;don't talk if in APCDALVR mode
IF $DATA(APCDATMP)
QUIT
+9 WRITE " ",X
+10 QUIT
PRLK(AUTFN,AUTVAL) ;
+1 NEW AUTVALI
+2 SET AUTVALI=""
+3 DO EN^XBNEW("DIC^AUPNVMSR","AUTFN,AUTVAL,AUTVALI")
+4 QUIT AUTVALI
PU ;EP (PULSE)
+1 IF +X'=X!(X>250)!(X<30)!(X?.E1"."1N.N)
KILL X
+2 QUIT
SN ;STATION
+1 IF X<-6!(X>4)
KILL X
+2 QUIT
TMP ; (TEMPERATURE)
+1 IF +X'=X!(X>120)!(X<70)!(X?.E1"."2N.N)
KILL X
+2 QUIT
TON ; (TONOMETRY)
+1 NEW %AURR,%AURP,%AURI,%AULR,%AULP,%AULI
+2 IF $LENGTH(X)>5!($LENGTH(X)<3)!'((X?1.3N1"/")!(X?1"/"1.3N)!(X?1.3N1"/"1.3N))
KILL X
QUIT
+3 IF $PIECE(X,"/",1)'=""
IF $PIECE(X,"/",1)<0!($PIECE(X,"/",1)>80)
KILL X
QUIT
+4 IF $PIECE(X,"/",2)'=""
IF $PIECE(X,"/",2)<0!($PIECE(X,"/",2)>80)
KILL X
QUIT
+5 IF $PIECE(X,"/",1)]""
SET X="R"_X
+6 IF $PIECE(X,"/",2)]""
SET X=$PIECE(X,"/",1)_"/L"_$PIECE(X,"/",2)
TONX ;
+1 KILL %AURR,%AURP,%AURI,%AULR,%AULP,%AULI
+2 QUIT
VC ; (VISION CORRECTED)
VU ; (VISION UNCORRECTED)
+1 ;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002 - do not do edit if in filegrams (mfi)
IF $DATA(DIFGLINE)
QUIT
+2 IF $LENGTH(X)>11!($LENGTH(X)<2)
KILL X
QUIT
+3 IF '((X?2.3AN)!(X?1"/"2.3AN)!(X?2.3AN1"/"2.3AN)!(X?2"/"2.3AN)!(X?1"/"2.3AN1"/"2.3N)!(X?2.3AN1"/"2.3AN1"/"2.3AN))
KILL X
QUIT
+4 IF $PIECE(X,"/",1)'=""
IF +($PIECE(X,"/",1))
IF $PIECE(X,"/",1)<10!($PIECE(X,"/",1)>999)
KILL X
QUIT
+5 IF $PIECE(X,"/",1)'=""
IF '($PIECE(X,"/",1))
IF $PIECE(X,"/")'="HM"&($PIECE(X,"/")'="LP")&($PIECE(X,"/")'="NLP")
KILL X
QUIT
+6 IF $PIECE(X,"/",2)'=""
IF +($PIECE(X,"/",2))
IF $PIECE(X,"/",2)<10!($PIECE(X,"/",2)>999)
KILL X
QUIT
+7 ;IHS/CMI/LAB -
IF $PIECE(X,"/",2)'=""
IF '($PIECE(X,"/",2))
IF $PIECE(X,"/",2)'="HM"&($PIECE(X,"/",2)'="LP")&($PIECE(X,"/",2)'="NLP")
KILL X
QUIT
+8 IF $PIECE(X,"/",3)'=""
IF +($PIECE(X,"/",3))
IF $PIECE(X,"/",3)<10!($PIECE(X,"/",3)>999)
KILL X
QUIT
+9 ;IHS/CMI/LAB - patch 17
IF $PIECE(X,"/",3)'=""
IF '($PIECE(X,"/",3))
IF $PIECE(X,"/",3)'="HM"&($PIECE(X,"/",3)'="LP")&($PIECE(X,"/",3)'="NLP")
KILL X
QUIT
+10 QUIT
WT ;EP (WEIGHT)
+1 IF X?.E.A.E
DO MWT
+2 IF '$DATA(X)
QUIT
+3 DO WTC
+4 IF $PIECE(X,".",2)?5N.N
SET X=X+.00005
SET X=$PIECE(X,".",1)_"."_$EXTRACT($PIECE(X,".",2),1,4)
+5 SET X=+X
+6 IF '$DATA(X)
QUIT
+7 IF +X'=X!(X>1000)!(X<2)!(X?.E1"."5N.N)
KILL X
+8 IF '$DATA(X)
QUIT
+9 ;K:X-(X\1)#.0625 X
+10 QUIT
WTC IF +X=X!(X'[" ")
QUIT
+1 IF '(X?1.3N1" "1.2N!(X?1.3N1" "1.2N1"/"1.2N))
QUIT
+2 IF X'["/"
IF +$PIECE(X," ",2)>16
QUIT
SET X=+X+(+$PIECE(X," ",2)/16)
QUIT
+3 IF +$PIECE($PIECE(X," ",2),"/",1)'<+$PIECE($PIECE(X," ",2),"/",2)
QUIT
+4 SET X=+X+((+$PIECE(X," ",2)/$PIECE($PIECE(X," ",2),"/",2)))
+5 QUIT
+6 ;
MWT ;
+1 NEW AUPNC,AUPNI,AUPNJ
+2 SET AUPNJ=$LENGTH(X)
FOR AUPNI=1:1:AUPNJ
SET AUPNC=$EXTRACT(X,AUPNI)
IF AUPNC?1A
SET AUPNC=$SELECT(AUPNC?1L:$CHAR($ASCII(AUPNC)-32),1:AUPNC)
+3 SET (AUPNI,AUPNC)=""
FOR AUPNI=1:1:AUPNJ
SET AUPNC=$EXTRACT(X,AUPNI)
IF "GK"[AUPNC
QUIT
+4 IF "GK"[AUPNC
DO @AUPNC
+5 KILL AUPNC,AUPNI,AUPNJ
+6 QUIT
MWTC ;
+1 IF +X=X!(X'[" ")!(X'["/")
QUIT
+2 IF '(X?1.6N1" "1.2N1"/"1.2N)
KILL X
+3 IF '$DATA(X)
QUIT
+4 SET X=+X+((+$PIECE(X," ",2)/$PIECE($PIECE(X," ",2),"/",2)))
+5 QUIT
K ;
+1 IF X["/"
SET X=$PIECE(X,AUPNC,1)
DO MWTC
+2 IF '$DATA(X)
QUIT
+3 SET X=+X
+4 SET X=(X*2.2046226)
+5 QUIT
G ;
+1 IF X["/"
SET X=$PIECE(X,AUPNC,1)
DO MWTC
+2 IF '$DATA(X)
QUIT
+3 SET X=+X
+4 SET X=(X*.0022046226)
+5 QUIT
C ;
+1 IF X["/"
SET X=$PIECE(X,AUPNC,1)
DO MWTC
+2 IF '$DATA(X)
QUIT
+3 SET X=+X
+4 SET X=(X*.393701)
+5 QUIT
AG ; (ABDOMINAL GIRTH)
+1 IF +X'=X!(X>250)!(X<10)!(X?.E1"."3N.N)
KILL X
+2 QUIT
FH ; Fundal Height
+1 IF +X'=X!(X>100)!(X<0)!(X?.E1"."3N.N)
KILL X
+2 QUIT
FT ; Fetal Heart Tones
+1 IF +X'=X!(X>400)!(X<0)!(X?.E1"."1N.N)
KILL X
+2 QUIT
RS ;EP
+1 ;IHS/CMI/LAB - up'ed value to 100 pre Madonna Long aberdeen
+2 IF X'?1.3N!(X<0)!(X>140)
KILL X
QUIT
+3 QUIT
+4 ;
O2 ;EP called from input template
+1 IF X'?1.3N!(X<50)!(X>100)
KILL X
+2 QUIT
PF ;EP called from input template
+1 ;IHS/CMI/LAB 1-25-08; values 5-1000 CR #85
IF X'?1.4N!(X<50)!(X>1000)
KILL X
+2 QUIT
BS ;EP -per dina in billings
+1 QUIT
CEF ;EP called from input tx, per Terry Cullen 3-17-04
+1 IF '$DATA(X)
QUIT
+2 IF (X<5)!(X>99)
KILL X
+3 QUIT
ASQM ; EP - ASQ questionnaire (Mos)
+1 IF '$DATA(^VEN(7.14,"B",X))
KILL X
+2 QUIT
+3 ;
PHQ2 ; EP - PHQ2
+1 IF X'?1N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>6)
KILL X
+4 QUIT
+5 ;
PHQ9 ; EP - PHQ9
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>27)
KILL X
+4 QUIT
PHQT ; EP - PHQT
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>27)
KILL X
+4 QUIT
+5 ;
AUDT ; EP - AUDT
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>40)
KILL X
+4 QUIT
+5 ;
AUDC ; EP - AUDT
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>12)
KILL X
+4 QUIT
+5 ;
CRFT ; EP - CRFT
+1 IF X'?1N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>6)
KILL X
+4 QUIT
+5 ;
ASFD ; EP - ASFD
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>14)
KILL X
+4 QUIT
+5 ;
ADM ; EP - ADM
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>14)
KILL X
+4 QUIT
+5 ;
BPF ;EP called from input template
+1 ;IHS/CMI/LAB 1-25-08; values 5-1000 CR #85
IF X'?1.4N!(X<50)!(X>1000)
KILL X
+2 QUIT
+3 ;
FEF ;EP - FEF 25-75
+1 SET X=$$STRIP^XLFSTR(X," ")
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>150)
KILL X
+4 QUIT
+5 ;
FEV1 ;EP - FEV1
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>10)
KILL X
+4 QUIT
+5 ;
FV1P ;EP - FEV1 %
+1 SET X=$$STRIP^XLFSTR(X," ")
+2 ;I X'?1.3N!(X'?1.3N1"%") K X
+3 IF X'=+X
KILL X
QUIT
+4 IF (X<0)!(X>150)
KILL X
+5 QUIT
+6 ;
FVC ;EP - forced vital capacity
+1 IF X'?1.2N
KILL X
QUIT
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>10)
KILL X
+4 QUIT
+5 ;
FVCP ;EP - FEV1 %
+1 SET X=$$STRIP^XLFSTR(X," ")
+2 IF X'=+X
KILL X
QUIT
+3 IF (X<0)!(X>150)
KILL X
+4 QUIT
+5 ;
FVFC ;EP - FEV1/FVC
+1 IF $LENGTH(X)>11!($LENGTH(X)<2)!'(X?0.2N0.1"."0.2N1"/"0.2N0.1"."0.2N)
KILL X
QUIT
+2 NEW F,S
+3 SET F=$PIECE(X,"/",1)
SET S=$PIECE(X,"/",2)
+4 IF F=""
KILL X
QUIT
+5 IF S=""
KILL X
QUIT
+6 SET F=+F
+7 SET S=+S
+8 IF F<0!(F>10)
KILL X
QUIT
+9 IF S<0!(S>10)
KILL X
QUIT
+10 QUIT
LKW ;EP - LKW
+1 IF X'="WELL"
KILL X
QUIT
+2 QUIT
EGA ;EP - EGA
+1 IF X?1.2N
Begin DoDot:1
+2 IF +X<4
KILL X
QUIT
+3 IF +X>44
KILL X
QUIT
End DoDot:1
QUIT
+4 IF X'?1.2N1" "1N1"/"1"7"
KILL X
QUIT
+5 NEW %
+6 SET %=$PIECE(X," ")
+7 IF %<4
KILL X
QUIT
+8 IF %>44
KILL X
QUIT
+9 SET %=$EXTRACT($PIECE(X," ",2))
+10 IF %<1
KILL X
QUIT
+11 IF %>6
KILL X
QUIT
+12 QUIT
+13 ;
ASQF ; EP - ASQ development score: FINE MOTOR
ASQG ; EP - ASQ development score: GROSS MOTOR
ASQL ; EP - ASQ development score: LANGUAGE
ASQS ; EP - ASQ development score: SOCIAL
ASQP ; EP - ASQ development score: PROBLEM SOLVING
+1 IF $PIECE(X," ")'?1.2N
KILL X
QUIT
+2 IF +X#5
KILL X
+3 QUIT
BL ;EP - called from birth length of Birth measurement file
+1 IF X=""
QUIT
+2 IF $EXTRACT(X)="C"
SET X=$EXTRACT(X,2,9999)
SET X=X*.3937008
+3 IF X'=+X
KILL X
QUIT
+4 IF X<6
KILL X
QUIT
+5 IF X>30
KILL X
QUIT
+6 QUIT
F10R ;EP (F10R)
+1 ;For women: <1, 1, 2, 3, 4, 5, 6, 8, 11, 14, 17, 22, 27, >30
+2 ;For men: <1, 1, 2, 3, 4, 5, 6, 8, 10, 12, 16, 20, 25, >30
+3 IF X="<1"
QUIT
+4 IF X=1
QUIT
+5 IF X=2
QUIT
+6 IF X=3
QUIT
+7 IF X=4
QUIT
+8 IF X=5
QUIT
+9 IF X=6
QUIT
+10 IF X=8
QUIT
+11 IF X=">30"
QUIT
+12 IF $GET(AUPNSEX)="F"!($GET(SEX)="F")
Begin DoDot:1
+13 IF X=11
QUIT
+14 IF X=14
QUIT
+15 IF X=17
QUIT
+16 IF X=22
QUIT
+17 IF X=27
QUIT
+18 KILL X
End DoDot:1
QUIT
+19 IF $GET(AUPNSEX)="M"!($GET(SEX)="M")
Begin DoDot:1
+20 IF X=10
QUIT
+21 IF X=12
QUIT
+22 IF X=16
QUIT
+23 IF X=20
QUIT
+24 IF X=25
QUIT
+25 KILL X
End DoDot:1
QUIT
+26 QUIT
+27 ;
OUT(IEN,VAL) ;EP called from output transform
+1 IF 'IEN
QUIT VAL
+2 IF '$DATA(^AUPNVMSR(IEN,0))
QUIT VAL
+3 NEW %
SET %=$PIECE(^AUPNVMSR(IEN,0),U)
+4 IF $PIECE(^AUTTMSR(%,0),U)="FEF"
QUIT $SELECT(VAL["%":VAL,1:VAL_"%")
+5 IF $PIECE(^AUTTMSR(%,0),U)="FV1P"
QUIT $SELECT(VAL["%":VAL,1:VAL_"%")
+6 IF $PIECE(^AUTTMSR(%,0),U)="FVCP"
QUIT $SELECT(VAL["%":VAL,1:VAL_"%")
+7 IF $PIECE(^AUTTMSR(%,0),U)="F10R"
QUIT $SELECT(VAL["%":VAL,1:VAL_"%")
+8 IF $PIECE(^AUTTMSR(%,0),U)="CDR"
Begin DoDot:1
+9 IF $PIECE(VAL,".",1)=""
SET VAL="0"_VAL
End DoDot:1
QUIT VAL
+10 IF $PIECE(^AUTTMSR(%,0),U)'="VC"&($PIECE(^AUTTMSR(%,0),U)'="VU")
QUIT VAL
+11 NEW X
+12 SET X=VAL
+13 SET VAL=$SELECT($PIECE(^AUPNVMSR(IEN,0),U,6):$PIECE(^AUPNVMSR(IEN,0),U,6),1:"20")_"/"_$PIECE(X,"/")_"-"_$SELECT($PIECE(^AUPNVMSR(IEN,0),U,6):$PIECE(^AUPNVMSR(IEN,0),U,6),1:"20")_"/"_$PIECE(X,"/",2)
Begin DoDot:1
+14 IF $PIECE(X,"/",3)]""
SET VAL=VAL_"-"_$SELECT($PIECE(^AUPNVMSR(IEN,0),U,6):$PIECE(^AUPNVMSR(IEN,0),U,6),1:"20")_"/"_$PIECE(X,"/",3)
End DoDot:1
+15 QUIT VAL
VCVU(VAL,DEN) ;EP - CALLED FROM MEASUREMENT PANEL
+1 NEW A
+2 SET A=$SELECT(DEN:DEN,1:"20")_"/"_$PIECE(VAL,"/")_"-"_$SELECT(DEN:DEN,1:"20")_"/"_$PIECE(VAL,"/",2)
Begin DoDot:1
+3 IF $PIECE(VAL,"/",3)]""
SET A=A_"-"_$SELECT(DEN:DEN,1:"20")_"/"_$PIECE(VAL,"/",3)
End DoDot:1
+4 QUIT A
HELP ;EP - HELP FOR VARIOUS TYPES
+1 DO ^AUPNVMS2
+2 QUIT
DIC ;EP
+1 NEW X
SET X=AUTVAL
+2 SET DIC=$$DIC^XBDIQ1(AUTFN)
+3 IF '$LENGTH(DIC)
QUIT
+4 SET DIC(0)="M"
+5 DO ^DIC
+6 IF +Y>0
SET AUTVALI=$PIECE(Y,U,2)
+7 QUIT
+8 ;
OUTBH(IEN,VAL) ;EP called from output transform
+1 IF 'IEN
QUIT VAL
+2 IF '$DATA(^AMHRMSR(IEN,0))
QUIT VAL
+3 NEW %
SET %=$PIECE(^AMHRMSR(IEN,0),U)
+4 IF $PIECE(^AUTTMSR(%,0),U)'="VC"&($PIECE(^AUTTMSR(%,0),U)'="VU")
QUIT VAL
+5 SET VAL=$SELECT($PIECE(^AMHRMSR(IEN,0),U,6):$PIECE(^AMHRMSR(IEN,0),U,6),1:"20")_"/"_$PIECE(VAL,"/")_"-"_$SELECT($PIECE(^AMHRMSR(IEN,0),U,6):$PIECE(^AMHRMSR(IEN,0),U,6),1:"20")_"/"_$PIECE(VAL,"/",2)
+6 QUIT VAL
EN1(Y,DA) ;EP - INPUT TRANSFORM FOR NAME (.01) FIELD OF QUALIFIER
+1 ; SUB-FILE OF V MEASUREMENT FILE.
+2 ; Input variables: Y is entry in 120.52 being looked up
+3 ; DA is entry in V MEASUREMENT where Qualifier data
+4 ; is being selected.
+5 ; Function value: 1 if can select this Qualifier, else 0.
+6 ;
+7 NEW GMRVFXN,GMRVTYP
SET GMRVFXN=0
+8 SET GMRVTYP=$PIECE($GET(^AUPNVMSR(DA,0)),"^",1)
+9 IF GMRVTYP>0
IF $DATA(^GMRD(120.52,"C",GMRVTYP,+Y))
SET GMRVFXN=1
+10 QUIT GMRVFXN
+11 ;
