ACMMSR.m

ACMMSR ; IHS/TUCSON/TMJ - EDITS FOR ACMVMSR ; [ 05/11/06  2:34 PM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**6**;JAN 10, 1996

 ;EP;ENTRY POINT

 S ACMMTYP=$P(^ACM(57,DA,0),U,1),ACMMTYP=$P(^AUTTMSR(ACMMTYP,0),U,1)

 D @ACMMTYP

 K ACMMTYP

 Q

 ;

AUD ; (AUDIOMETRY)

 I $L(X,"/")'=17 K X Q

 F ACMUI=1:1:16 S ACMUX=$P(X,"/",ACMUI) I ACMUX'="" I ACMUX'?1.3N!(+ACMUX>110) K X Q

 K ACMUI,ACMUX

 Q

BP ; (BLOOD PRESSURE)

 I $L(X)>7!($L(X)<5)!'(X?2.3N1"/"2.3N) K X Q

 S ACMBPS=+$P(X,"/",1),ACMBPD=+$P(X,"/",2)

 I ACMBPS<20!(ACMBPS>275) K X G BPX

 I ACMBPD<20!(ACMBPD>200) K X G BPX

 I ACMBPS'>ACMBPD K X G BPX

 S X=ACMBPS_"/"_ACMBPD

BPX K ACMBPS,ACMBPD

 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

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>80)!(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 ;

 S ACMJ=$L(X) F ACMI=1:1:ACMJ S ACMC=$E(X,ACMI) I ACMC?1A S ACMC=$S(ACMC?1L:$C($A(ACMC)-32),1:ACMC)

 S (ACMI,ACMC)="" F ACMI=1:1:ACMJ S ACMC=$E(X,ACMI) Q:"C"[ACMC

 I ACMC="C" D @ACMC

 K ACMC,ACMI,ACMJ

 Q

PU ; (PULSE)

 K:+X'=X!(X>250)!(X<30)!(X?.E1"."1N.N) X

 Q

TMP ; (TEMPERATURE)

 K:+X'=X!(X>109.9)!(X<94)!(X?.E1"."2N.N) X

 Q

TON ; (TONOMETRY)

 I $L(X,"/")'=7 K X Q

 S ACMURR=$P(X,"/",1),ACMURP=$P(X,"/",2),ACMURI=$P(X,"/",3)

 S ACMULR=$P(X,"/",4),ACMULP=$P(X,"/",5),ACMULI=$P(X,"/",6)

 I ACMURR'="" I ACMURR'?1.2N1"."1N!(+ACMURR>99) K X G TONX

 I ACMURP'="" I ACMURP'="5.5"&(ACMURP'="7.5")&(ACMURP'="10.0")&(ACMURP'="15.0") K X G TONX

 I ACMURI'="" I ACMURI'?1.3N1"."1N!(+ACMURI>999.9) K X G TONX

 I ACMULR'="" I ACMULR'?1.2N1"."1N!(+ACMULR>99) K X G TONX

 I ACMULP'="" I ACMULP'="5.5"&(ACMULP'="7.5")&(ACMULP'="10.0")&(ACMULP'="15.0") K X G TONX

 I ACMULI'="" I ACMULI'?1.3N1"."1N!(+ACMULI>999.9) K X G TONX

 I ACMURR="" I ACMURP=""!(ACMURI="") K X G TONX

 I ACMURR'="" I ACMURP'=""!(ACMURI'="") K X G TONX

 I ACMULR="" I ACMULP=""!(ACMULI="") K X G TONX

 I ACMURR'="" I ACMURP'=""!(ACMURI'="") K X G TONX

TONX ;

 K ACMURR,ACMURP,ACMURI,ACMULR,ACMULP,ACMULI

 Q

VC ; (VISION CORRECTED)

VU ; (VISION UNCORRECTED)

 I $L(X)>7!($L(X)<2)!'((X?2.3N)!(X?1"/"2.3N)!(X?2.3N1"/"2.3N)) K X Q

 I $P(X,"/",1)'="" I $P(X,"/",1)<10!($P(X,"/",1)>999) K X Q

 I $P(X,"/",2)'="" I $P(X,"/",2)<10!($P(X,"/",2)>999) K X Q

 Q

WT ; (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>750)!(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 ;

 S ACMJ=$L(X) F ACMI=1:1:ACMJ S ACMC=$E(X,ACMI) I ACMC?1A S ACMC=$S(ACMC?1L:$C($A(ACMC)-32),1:ACMC)

 S (ACMI,ACMC)="" F ACMI=1:1:ACMJ S ACMC=$E(X,ACMI) Q:"GK"[ACMC

 I "GK"[ACMC D @ACMC

 K ACMC,ACMI,ACMJ

 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,ACMC,1) D MWTC

 Q:'$D(X)

 S X=+X

 S X=(X*2.2046226)

 Q

G ;

 I X["/" S X=$P(X,ACMC,1) D MWTC

 Q:'$D(X)

 S X=+X

 S X=(X*.0022046226)

 Q

C ;

 I X["/" S X=$P(X,ACMC,1) D MWTC

 Q:'$D(X)

 S X=+X

 S X=(X*.393701)

 Q

AG ; (ABDOMINAL GIRTH)

 K:+X'=X!(X>150)!(X<0)!(X?.E1"."1N.N) X

 Q

FH ; Fundal Height

 K:+X'=X!(X>50)!(X<10)!(X?.E1"."1N.N) X

 Q

FT ; Fetal Heart Tones

 K:+X'=X!(X>250)!(X<50)!(X?.E1"."1N.N) X

 Q

HELP ;EP; HELP FOR VARIOUS TYPES ;IHS/CMI/TMJ PATCH #6

 D ^ACMMS2

 Q

DIC ;EP; IHS/CMI/TMJ PATCH #6

 N X S X=ACMVAL

 S DIC=$$DIC^XBDIQ1(ACMFN)

 Q:'$L(DIC)

 S DIC(0)="M"

 D ^DIC

 S:+Y>0 ACMVALI=$P(Y,U,2)

 Q

CXD ;;CERVIX DILATATION ;IHS/CMI/TMJ PATCH #6

 K:X<0!(X>10) X

 Q

ED ; (EDEMA) ;IHS/CMI/TMJ PATCH #6

 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; IHS/CMI/TMJ PATCH #6

 K:X<0!(X>100) X

 Q

WC ;  (WAIST CIRCUMFERENCE) ;IHS/CMI/TMJ PATCH #6

 I X'=+X K X Q

 K:+X'=X!(X>99)!(X<20)!(X?.E1"."3N.N) X

 Q

PA ;EP (PAIN) ;IHS/CMI/TMJ PATCH #6

 I X'=+X K X Q

 K:(X<0)!(X>10) X

 Q

PR ; (PRESENTATION)RS ;EP ;IHS/CMI/TMJ PATCH #6

 ;IHS/CMI/LAB - up'ed value to 100 pre Madonna Long aberdeen

 I X'?1.2N!(X<8)!(X>100) K X Q

 Q

 ;IHS/CMI/LAB - aupn9320 patch 8 added O2 and PF subroutines

O2 ;EP called from input te ;IHS/CMI/TMJ PATCH #6mplate

 I X'?1.3N!(X<50)!(X>100) K X

 Q

PF ;EP called from input te ;IHS/CMI/TMJ PATCH #6mplate

 I X'?1.3N!(X<50)!(X>900) K X

 Q

BS ;EP -per dina in billings ;IHS/CMI/TMJ PATCH #6

 Q

CEF ;EP called from input tx, per Terry Cullen 3-17-04 ;IHS/CMI/TMJ PATCH #6

 Q:'$D(X)

 K:(X<5)!(X>99) X

 Q

OUT ;IHS/CMI/TMJ PATCH #6

 NEW ACMFN,ACMVAL

 S ACMVAL=X,ACMFN=9999999.87

 S %=$$PRLK(ACMFN,ACMVAL)

 I %="" K X Q

 S X=%

 Q:$D(ZTQUEUED)

 Q:$D(APCDATMP)  ;don't talk if in APCDALVR mode

 W "   ",X

 Q

PRLK(ACMFN,ACMVAL) ;

 NEW ACMVALI

 S ACMVALI=""

 D EN^XBNEW("DIC^AUPNVMSR","ACMFN,ACMVAL,ACMVALI")

 Q ACMVALI

SN ;STATION

 K:X<-6!(X>4) X

 Q

ACMMSR    ; IHS/TUCSON/TMJ - EDITS FOR ACMVMSR ; [ 05/11/06  2:34 PM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;**6**;JAN 10, 1996

 +2       ;EP;ENTRY POINT

 +3        SET ACMMTYP=$PIECE(^ACM(57,DA,0),U,1)

           SET ACMMTYP=$PIECE(^AUTTMSR(ACMMTYP,0),U,1)

 +4        DO @ACMMTYP

 +5        KILL ACMMTYP

 +6        QUIT 

 +7       ;

AUD       ; (AUDIOMETRY)

 +1        IF $LENGTH(X,"/")'=17

               KILL X

               QUIT 

 +2        FOR ACMUI=1:1:16

               SET ACMUX=$PIECE(X,"/",ACMUI)

               IF ACMUX'=""

                   IF ACMUX'?1.3N!(+ACMUX>110)

                       KILL X

                       QUIT 

 +3        KILL ACMUI,ACMUX

 +4        QUIT 

BP        ; (BLOOD PRESSURE)

 +1        IF $LENGTH(X)>7!($LENGTH(X)<5)!'(X?2.3N1"/"2.3N)

               KILL X

               QUIT 

 +2        SET ACMBPS=+$PIECE(X,"/",1)

           SET ACMBPD=+$PIECE(X,"/",2)

 +3        IF ACMBPS<20!(ACMBPS>275)

               KILL X

               GOTO BPX

 +4        IF ACMBPD<20!(ACMBPD>200)

               KILL X

               GOTO BPX

 +5        IF ACMBPS'>ACMBPD

               KILL X

               GOTO BPX

 +6        SET X=ACMBPS_"/"_ACMBPD

BPX        KILL ACMBPS,ACMBPD

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

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>80)!(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        SET ACMJ=$LENGTH(X)

           FOR ACMI=1:1:ACMJ

               SET ACMC=$EXTRACT(X,ACMI)

               IF ACMC?1A

                   SET ACMC=$SELECT(ACMC?1L:$CHAR($ASCII(ACMC)-32),1:ACMC)

 +2        SET (ACMI,ACMC)=""

           FOR ACMI=1:1:ACMJ

               SET ACMC=$EXTRACT(X,ACMI)

               IF "C"[ACMC

                   QUIT 

 +3        IF ACMC="C"

               DO @ACMC

 +4        KILL ACMC,ACMI,ACMJ

 +5        QUIT 

PU        ; (PULSE)

 +1        IF +X'=X!(X>250)!(X<30)!(X?.E1"."1N.N)

               KILL X

 +2        QUIT 

TMP       ; (TEMPERATURE)

 +1        IF +X'=X!(X>109.9)!(X<94)!(X?.E1"."2N.N)

               KILL X

 +2        QUIT 

TON       ; (TONOMETRY)

 +1        IF $LENGTH(X,"/")'=7

               KILL X

               QUIT 

 +2        SET ACMURR=$PIECE(X,"/",1)

           SET ACMURP=$PIECE(X,"/",2)

           SET ACMURI=$PIECE(X,"/",3)

 +3        SET ACMULR=$PIECE(X,"/",4)

           SET ACMULP=$PIECE(X,"/",5)

           SET ACMULI=$PIECE(X,"/",6)

 +4        IF ACMURR'=""

               IF ACMURR'?1.2N1"."1N!(+ACMURR>99)

                   KILL X

                   GOTO TONX

 +5        IF ACMURP'=""

               IF ACMURP'="5.5"&(ACMURP'="7.5")&(ACMURP'="10.0")&(ACMURP'="15.0")

                   KILL X

                   GOTO TONX

 +6        IF ACMURI'=""

               IF ACMURI'?1.3N1"."1N!(+ACMURI>999.9)

                   KILL X

                   GOTO TONX

 +7        IF ACMULR'=""

               IF ACMULR'?1.2N1"."1N!(+ACMULR>99)

                   KILL X

                   GOTO TONX

 +8        IF ACMULP'=""

               IF ACMULP'="5.5"&(ACMULP'="7.5")&(ACMULP'="10.0")&(ACMULP'="15.0")

                   KILL X

                   GOTO TONX

 +9        IF ACMULI'=""

               IF ACMULI'?1.3N1"."1N!(+ACMULI>999.9)

                   KILL X

                   GOTO TONX

 +10       IF ACMURR=""

               IF ACMURP=""!(ACMURI="")

                   KILL X

                   GOTO TONX

 +11       IF ACMURR'=""

               IF ACMURP'=""!(ACMURI'="")

                   KILL X

                   GOTO TONX

 +12       IF ACMULR=""

               IF ACMULP=""!(ACMULI="")

                   KILL X

                   GOTO TONX

 +13       IF ACMURR'=""

               IF ACMURP'=""!(ACMURI'="")

                   KILL X

                   GOTO TONX

TONX      ;

 +1        KILL ACMURR,ACMURP,ACMURI,ACMULR,ACMULP,ACMULI

 +2        QUIT 

VC        ; (VISION CORRECTED)

VU        ; (VISION UNCORRECTED)

 +1        IF $LENGTH(X)>7!($LENGTH(X)<2)!'((X?2.3N)!(X?1"/"2.3N)!(X?2.3N1"/"2.3N))

               KILL X

               QUIT 

 +2        IF $PIECE(X,"/",1)'=""

               IF $PIECE(X,"/",1)<10!($PIECE(X,"/",1)>999)

                   KILL X

                   QUIT 

 +3        IF $PIECE(X,"/",2)'=""

               IF $PIECE(X,"/",2)<10!($PIECE(X,"/",2)>999)

                   KILL X

                   QUIT 

 +4        QUIT 

WT        ; (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>750)!(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        SET ACMJ=$LENGTH(X)

           FOR ACMI=1:1:ACMJ

               SET ACMC=$EXTRACT(X,ACMI)

               IF ACMC?1A

                   SET ACMC=$SELECT(ACMC?1L:$CHAR($ASCII(ACMC)-32),1:ACMC)

 +2        SET (ACMI,ACMC)=""

           FOR ACMI=1:1:ACMJ

               SET ACMC=$EXTRACT(X,ACMI)

               IF "GK"[ACMC

                   QUIT 

 +3        IF "GK"[ACMC

               DO @ACMC

 +4        KILL ACMC,ACMI,ACMJ

 +5        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,ACMC,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,ACMC,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,ACMC,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>150)!(X<0)!(X?.E1"."1N.N)

               KILL X

 +2        QUIT 

FH        ; Fundal Height

 +1        IF +X'=X!(X>50)!(X<10)!(X?.E1"."1N.N)

               KILL X

 +2        QUIT 

FT        ; Fetal Heart Tones

 +1        IF +X'=X!(X>250)!(X<50)!(X?.E1"."1N.N)

               KILL X

 +2        QUIT 

HELP      ;EP; HELP FOR VARIOUS TYPES ;IHS/CMI/TMJ PATCH #6

 +1        DO ^ACMMS2

 +2        QUIT 

DIC       ;EP; IHS/CMI/TMJ PATCH #6

 +1        NEW X

           SET X=ACMVAL

 +2        SET DIC=$$DIC^XBDIQ1(ACMFN)

 +3        IF '$LENGTH(DIC)

               QUIT 

 +4        SET DIC(0)="M"

 +5        DO ^DIC

 +6        IF +Y>0

               SET ACMVALI=$PIECE(Y,U,2)

 +7        QUIT 

CXD       ;;CERVIX DILATATION ;IHS/CMI/TMJ PATCH #6

 +1        IF X<0!(X>10)

               KILL X

 +2        QUIT 

ED        ; (EDEMA) ;IHS/CMI/TMJ PATCH #6

 +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; IHS/CMI/TMJ PATCH #6

 +1        IF X<0!(X>100)

               KILL X

 +2        QUIT 

WC        ;  (WAIST CIRCUMFERENCE) ;IHS/CMI/TMJ PATCH #6

 +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) ;IHS/CMI/TMJ PATCH #6

 +1        IF X'=+X

               KILL X

               QUIT 

 +2        IF (X<0)!(X>10)

               KILL X

 +3        QUIT 

PR        ; (PRESENTATION)RS ;EP ;IHS/CMI/TMJ PATCH #6

 +1       ;IHS/CMI/LAB - up'ed value to 100 pre Madonna Long aberdeen

 +2        IF X'?1.2N!(X<8)!(X>100)

               KILL X

               QUIT 

 +3        QUIT 

 +4       ;IHS/CMI/LAB - aupn9320 patch 8 added O2 and PF subroutines

O2        ;EP called from input te ;IHS/CMI/TMJ PATCH #6mplate

 +1        IF X'?1.3N!(X<50)!(X>100)

               KILL X

 +2        QUIT 

PF        ;EP called from input te ;IHS/CMI/TMJ PATCH #6mplate

 +1        IF X'?1.3N!(X<50)!(X>900)

               KILL X

 +2        QUIT 

BS        ;EP -per dina in billings ;IHS/CMI/TMJ PATCH #6

 +1        QUIT 

CEF       ;EP called from input tx, per Terry Cullen 3-17-04 ;IHS/CMI/TMJ PATCH #6

 +1        IF '$DATA(X)

               QUIT 

 +2        IF (X<5)!(X>99)

               KILL X

 +3        QUIT 

OUT       ;IHS/CMI/TMJ PATCH #6

 +1        NEW ACMFN,ACMVAL

 +2        SET ACMVAL=X

           SET ACMFN=9999999.87

 +3        SET %=$$PRLK(ACMFN,ACMVAL)

 +4        IF %=""

               KILL X

               QUIT 

 +5        SET X=%

 +6        IF $DATA(ZTQUEUED)

               QUIT 

 +7       ;don't talk if in APCDALVR mode

           IF $DATA(APCDATMP)

               QUIT 

 +8        WRITE "   ",X

 +9        QUIT 

PRLK(ACMFN,ACMVAL) ;

 +1        NEW ACMVALI

 +2        SET ACMVALI=""

 +3        DO EN^XBNEW("DIC^AUPNVMSR","ACMFN,ACMVAL,ACMVALI")

 +4        QUIT ACMVALI

SN        ;STATION

 +1        IF X<-6!(X>4)

               KILL X

 +2        QUIT