Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFDE3

IBDFDE3.m

Go to the documentation of this file.
  1. IBDFDE3 ;ALB/AAS - AICS Manual Data Entry, process handprint fields ; 24-FEB-96
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. % G ^IBDFDE
  1. ;
  1. HNDPR(RESULT,IBDF) ; -- Procedure
  1. ; -- Manual Data entry routine for Hand Print Fields
  1. ; Input : Result := call by reference, used to output results
  1. ; IBDF("IEN") := pointer to hand print file (359.94)
  1. ; IBDF("PI") := pointer to input package interface
  1. ; IBDF("DFN") := pointer to patient
  1. ; IBDF("CLINIC") := pointer to hospital location
  1. ;
  1. ; output: Result(n) $p1 := pointer to package interface
  1. ; $p2 := input value (validated user input)
  1. ; $p3 := null
  1. ; $p4 := null
  1. ; $p5 := null
  1. ; $p6 := measurement type for vitals
  1. ; $p7 := ien in handprint file
  1. ; $p8 := vital type (name from 359.1)
  1. ; $P9 := Units (for Vitals)
  1. ; ibdpi(package interface, qlfr or n) := result(n)
  1. ; $P13 := number of the selection
  1. ;
  1. N I,J,X,Y,ANS,DISPTXT,HDR,DIR,DIRUT,DUOUT,DTOUT,IBDX,QLFR,CHOICE,OVER,IBDPRE
  1. S (IBQUIT,OVER)=0,(ANS,QLFR)=""
  1. D OBJLST^IBDFRPC1(.CHOICE,.IBDF)
  1. I +CHOICE(0)<1 G HPQ
  1. S IBDASK=$P(CHOICE(1),"^")_" "
  1. I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
  1. I $P($G(^IBE(357.6,+IBDF("PI"),0)),"^")["INPUT VITALS" S QLFR=$P(CHOICE(1),"^",5)
  1. ;
  1. OVER ;
  1. K X,Y,DIR,DIRUT,DUOUT,DTOUT
  1. S OVER=0
  1. S DIR("?")="Enter the value on the form, or enter Return if there is no value"
  1. S DIR(0)="FOA^2:"_$P(CHOICE(1),"^",3)
  1. I $G(QLFR)'="",$P($G(IBDPI(IBDF("PI"),QLFR)),"^",2)'="" S DIR("B")=$P($G(IBDPI(IBDF("PI"),QLFR)),"^",2)
  1. S DIR("A")=$P(CHOICE(1),"^")_" "
  1. I $D(IBDF("ASKDATE")) S Y=$$ASKDT^IBDFDE0(DIR("A"),$S($D(DIR("B")):DIR("B"),1:$G(IBDF("DEFLT"))),"",IBDF("APPT")) G REV
  1. D ^DIR
  1. REV I $G(IBDREDIT),$G(DIR("B"))'="" S IBDPRE=DIR("B") G:Y=$G(DIR("B")) HPQ
  1. S ANS=$$UP^XLFSTR(Y)
  1. K DIR
  1. I $G(IBDREDIT),$G(IBDPRE)'="",ANS="" D DELETE W " Deleted!" G HPQ
  1. I ANS="" G HPQ
  1. I ANS["^",ANS'="^" D G HPOVER
  1. .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
  1. .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
  1. .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
  1. .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
  1. .S IBQUIT=1
  1. I $D(DIRUT) S IBQUIT=1 G HPQ
  1. ;
  1. VITALS ; -- if vitals, validate input
  1. S OVER=0
  1. I $G(QLFR)'="" D I OVER G HPOVER
  1. .I $L($T(RATECHK^GMRVPCE0)) D Q
  1. ..S OVER='$$RATECHK^GMRVPCE0(QLFR,ANS,$P(CHOICE(1),"^",6))
  1. ..Q:'OVER
  1. ..D HELP^GMRVPCE0(QLFR,"HELP")
  1. ..W ! S IBDX="" F S IBDX=$O(HELP(IBDX)) Q:IBDX="" W !,HELP(IBDX)
  1. ..W ! K ANS,HELP
  1. .I $L($T(@(QLFR))) D @QLFR Q
  1. ;
  1. ; -- delete old answer
  1. I $G(IBDREDIT),$G(IBDPRE)'="",$G(IBDPRE)'=ANS D DELETE
  1. ;
  1. I ANS'="" D
  1. .S RESULT(0)=$G(RESULT(0))+1
  1. .S RESULT(RESULT(0))=+IBDF("PI")_"^"_ANS_"^^^^"_QLFR_"^"_$G(IBDF("IEN"))_"^"_$G(IBDF("VITAL"))_"^"_$P(CHOICE(1),"^",4)
  1. .S IBDPI(IBDF("PI"),$S($G(QLFR)'="":QLFR,1:RESULT(0)))=IBDSEL(RESULT(0))
  1. .S $P(IBDPI(IBDF("PI"),$S($G(QLFR)'="":QLFR,1:RESULT(0))),"^",13)=RESULT(0)
  1. ;
  1. HPOVER G:OVER OVER
  1. HPQ Q
  1. ;
  1. DELETE ; -- delete old answer if changed
  1. Q:'$G(IBDREDIT)!(ANS=$G(IBDPRE))
  1. S SEL=+$P($G(IBDPI(IBDF("PI"),QLFR)),"^",13) Q:'SEL
  1. K IBDPI(IBDF("PI"),QLFR),RESULT(SEL)
  1. I $G(RESULT(0))=1 S RESULT(0)=0
  1. Q
  1. ;
  1. BP ; -- validate blood pressure
  1. N D,S
  1. I ANS'?2.3N1"/"2.3N S OVER=1 K ANS G BPQ
  1. S S=$P(ANS,"/"),D=$P(ANS,"/",2)
  1. I D<20!(D>200)!(S<20)!(S>275) K ANS S OVER=1
  1. I S'>D K ANS S OVER=1
  1. BPQ 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.",!
  1. Q
  1. ;
  1. WT ; -- validate body weight
  1. I ANS'?1.3N.1".".1N!(ANS<2)!(ANS>750)!(+ANS'=ANS) K ANS S OVER=1
  1. WTQ I OVER W !,"Enter a body weight, 1 decimal place allowed, between 2 and 750 lbs.",!
  1. Q
  1. ;
  1. HT ; --validate body height
  1. I ANS'?2N.1".".1N!(ANS<10)!(ANS>80) K ANS S OVER=1
  1. I OVER W !,"Enter the body height in inches, 1 decimal place allowed, between 10 and 80.",!
  1. Q
  1. ;
  1. AG ; -- validate adominal girth
  1. I +ANS'=ANS!(ANS?.E1"."1N.N)!(ANS<10)!(ANS>750) K ANS S OVER=1
  1. I OVER W !,"Enter the abdominal girth in inches, no decimal places, between 10 and 750.",!
  1. Q
  1. ;
  1. AUD ; -- validate audiometry
  1. N %AUI,%AUX
  1. I $L(ANS,"/")'=17 K ANS S OVER=1
  1. F %AUI=1:1:16 S %AUX=$P(X,"/",%AUI) I %AUX'="" I %AUX'?1.3N!(+%AUX>110) K ANS S OVER=1
  1. 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/",!
  1. Q
  1. ;
  1. TMP ; -- validate temperature
  1. I ANS'?2.3N.1".".1N!(ANS<94)!(ANS>109.9)!(+ANS'=ANS) K ANS S OVER=1
  1. I OVER W !,"Enter the body temperature in degrees fahrenheit, must be between 94 and 109.9.",!
  1. Q
  1. ;
  1. FT ; -- validate fetal heart tones
  1. I ANS'=+ANS!(ANS<50)!(ANS>250)!(ANS?.E1"."1N.N) K ANS S OVER=1
  1. I OVER W !,"Enter Fetal Heart Tone. Must be in the range 50 -250.",!
  1. Q
  1. ;
  1. FH ; -- validate fundal height
  1. I ANS'=+ANS!(ANS<10)!(ANS>250)!(ANS?.E1"."1N.N) K ANS S OVER=1
  1. I OVER W !,"Enter a fundal Height. Must be in the range 10 - 50",!
  1. Q
  1. ;
  1. HC ; -- validate head circumference
  1. I ANS'=+ANS!(ANS<10)!(ANS>30)!(ANS?.E1"."3N.N) K ANS S OVER=1
  1. 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)",!
  1. Q
  1. ;
  1. HE ; -- validate hearing
  1. S ANS=$$UP^XLFSTR($E(ANS))
  1. I "AN"'[ANS K ANS S OVER=1
  1. I OVER W !,"Enter 'A' for abnormal, or 'N' for Normal.",!
  1. Q
  1. ;
  1. PU ; -- validate pulse
  1. I ANS'?1.3N!(ANS<30)!(ANS>250) K ANS S OVER=1
  1. I OVER W !,"Enter the patients 1 minute pulse, enter a number between 30 and 250.",!
  1. Q
  1. ;
  1. RS ; -- validate respirations
  1. I ANS'?1.2N!(ANS<8)!(ANS>90) K ANS S OVER=1
  1. I OVER W !,"Enter the patients 1 minute number of resperations, enter a number between 8 and 90.",!
  1. Q
  1. ;
  1. TON ; -- validate tonometry
  1. N AUTONR,AUTONL
  1. 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
  1. S AUTONR=$P(ANS,"/",1) S:AUTONR?1"R".N AUTONR=$E(AUTONR,2,10)
  1. S AUTONL=$P(ANS,"/",2) S:AUTONL?1"L".N AUTONL=$E(AUTONL,2,10)
  1. I AUTONR'="" I AUTONR<0!(AUTONR>80) K ANS S OVER=1
  1. I AUTONL'="" I AUTONL<0!(AUTONL>80) K ANS S OVER=1
  1. TONX 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"
  1. Q
  1. ;
  1. VC ; -- validate vision corrected
  1. ; same input as uncorrected
  1. VU ; -- validate vision uncorrected
  1. I $L(ANS)>7!($L(ANS)<2)!'((ANS?2.3N)!(ANS?1"/"2.3N)!(ANS?2.3N1"/"2.3N)) K ANS S OVER=1
  1. I $P(ANS,"/",1)'="" I $P(ANS,"/",1)<10!($P(ANS,"/",1)>999) K ANS S OVER=1
  1. I $P(ANS,"/",2)'="" I $P(ANS,"/",2)<10!($P(ANS,"/",2)>999) K ANS S OVER=1
  1. 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."
  1. Q