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
