BKMIXX4 ;PRXM/HC/CJS - IEN LOOKUP UTILITIES ; 05 Aug 2005 1:55 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
IMM(BKMN,XACT) ;IMMUNIZATION NAME TO IEN
;The variable BKMN, which is the name of the immunization is
;passed into the subroutine. This may be passed as a number or an
;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
;If more than one IEN can be applied, an array called BKMIENX is
;created to contain all of the applicable IENs.
K BKMIEN,BKMIENX,BKMN1
I $G(XACT)=1 D
.S BKMIEN=$O(^AUTTIMM("B",BKMN,0))
.Q
I BKMN?1.N D
.S BKMIEN=$S('$D(^AUTTIMM(BKMN)):-1,1:BKMN)
.Q
I BKMN'?1.N D
.S BKMN1=$E(BKMN,1,($L(BKMN)-1))
.F S BKMN1=$O(^AUTTIMM("B",BKMN1)) Q:BKMN1=""!($E(BKMN1,1,$L(BKMN))'=BKMN) D
..S BKMIEN=$O(^AUTTIMM("B",BKMN1,0)),BKMIENX(BKMIEN)="",BKMIENX=$G(BKMIENX)+1
.Q
Q $S(BKMIENX>1:0,1:BKMIEN)
;
;
LAB(BKMN,XACT) ;LABORATORY TEST NAME TO IEN
;The variable BKMN, which is the name of the lab test is
;passed into the subroutine. This may be passed as a number or an
;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
;If more than one IEN can be applied, an array called BKMIENX is
;created to contain all of the applicable IENs.
K BKMIEN,BKMIENX
I XACT=1 D
.S BKMIEN=$O(^LAB(60,"B",BKMN,0))
.Q
I BKMN?1.N D
.S BKMIEN=$S('$D(^LAB(60,BKMN)):-1,1:BKMN)
.Q
I BKMN'?1.N D
.S BKMN1=$E(BKMN,1,($L(BKMN)-1))
.F S BKMN1=$O(^LAB(60,"B",BKMN1)) Q:BKMN1=""!($E(BKMN1,1,$L(BKMN))'=BKMN) D
..S BKMIEN=$O(^LAB(60,"B",BKMN1,0)),BKMIENX(BKMIEN)="",BKMIENX=$G(BKMIENX)+1
.Q
Q $S(BKMIENX>1:0,1:BKMIEN)
;
LOINC(BKMN) ;LABORATORY TEST LOINC TO IEN
;The variable BKMN, which is the LOINC number of the lab test is
;passed into the subroutine. This may be passed as a number or an
;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
;If more than one IEN can be applied, an array called BKMIENX is
;created to contain all of the applicable IENs.
K BKMIEN,BKMIENX I BKMN?1.N D
.S BKMIEN=$S('$D(^LAB(60,"AF",BKMN,0)):-1,1:$O(^LAB(60,"AF",BKMN,0)))
.Q
I BKMN'?1.N D
.S BKMN1=$E(BKMN,1,($L(BKMN)-1))
.F S BKMN1=$O(^LAB(60,"AF",BKMN1)) Q:BKMN1=""!($E(BKMN1,1,$L(BKMN))'=BKMN) D
..S BKMIEN=$O(^LAB(60,"AF",BKMN1,0)),BKMIENX(BKMIEN)="",BKMIENX=$G(BKMIENX)+1
.Q
Q $S(BKMIENX>1:0,1:BKMIEN)
;
MEDS(BKMN,XACT) ;DRUG NAME TO IEN
;The variable BKMN, which is the name of the medication is
;passed into the subroutine. This may be passed as a number or an
;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
;If more than one IEN can be applied, an array called BKMIENX is
;created to contain all of the applicable IENs.
K BKMIEN,BKMIENX
I XACT=1 D
.S BKMIEN=$O(^PSDRUG("B",BKMN,0))
.Q
I BKMN?1.N D
.S BKMIEN=$S('$D(^PSDRUG(BKMN)):-1,1:BKMN)
.Q
I BKMN'?1.N D
.S BKMN1=$E(BKMN,1,($L(BKMN)-1))
.F S BKMN1=$O(^PSDRUG("B",BKMN1)) Q:BKMN1=""!($E(BKMN1,1,$L(BKMN))'=BKMN) D
..S BKMIEN=$O(^PSDRUG("B",BKMN1,0)),BKMIENX(BKMIEN)="",BKMIENX=$G(BKMIENX)+1
.Q
Q $S(BKMIENX>1:0,1:BKMIEN)
BMI(X,Y) ;Calculate Body Mass Index
;The variable X is the weight in pounds
;The variable Y is the height in inches
N BKMBMI
S BKMBMI=(X/(Y*Y))*703,BKMBMI=(BKMBMI*10)\1/10
Q BKMBMI
; This routine will pad a variable in the front or back, using
; any character that you specify; to the desired length.
; VAR is the string of characters that you would like to pad.
; FB indicates if you want to pad at the front or back of the string VAR.
; An FB value of "<" indicates that you want to pad at the front.
; An FB value of ">" indicates that you want to pad at the back.
; CHAR indicates the character that you want to use to pad the variable VAR with.
; LEN indicates the length that you want to pad the variable VAR to.
;
; The value is returned extrinsically.
PAD(VAR,FB,CHAR,LEN) ;EP
N PAD
S $P(PAD,CHAR,LEN+1)=""
I $L(VAR)>LEN Q $E(VAR,1,LEN)
I FB="<" Q $E(PAD,1,LEN-$L(VAR))_VAR
I FB=">" Q VAR_$E(PAD,1,LEN-$L(VAR))
Q $E(VAR,1,LEN)
PROMPT(PAR,OPTS,OPTA,FIRST,SECOND) ;EP
; INPUT
; PAR - Parameter for piece 1 of DIR(0)
; OPTS - Array passed by reference containing the option names that
; ^DIR will display
; OPTA - DIR("A") value for prompt to user
; FIRST - Do we execute the first prompt? $$PROMPT^BKMIXX4
; SECOND - Do we execute the second prompt?
ENT N STOP
S STOP=0
I FIRST D
.S Y=$$PROMPT2^BKMIXX4(PAR,.OPTS,OPTA)
.I $G(Y)?1."^"!('$G(Y))!($G(Y)<0) S Y=-1,STOP=1
I STOP Q 1_U_Y
S SEL=Y
S HIVTAX=$S(Y=1:1,1:0)
I 'SECOND Q 0_U_SEL
I 'FIRST D
.S HIVTAX=0,ENDDATE=DT,BEGDATE=ENDDATE-10000
.S ENDDT=$$FMTE^XLFDT(ENDDATE),BEGDT=$$FMTE^XLFDT(BEGDATE)
S DIR(0)="DO",DIR("A")="Beginning date",DIR("B")=BEGDT
D ^DIR
;Q:Y?1."^" 1
I $D(DTOUT)!$D(DUOUT) Q 1
W " ("_$$FMTE^XLFDT(Y)_")" H 1
S NOW=$P($$NOW^XLFDT,".")
I (Y>NOW) W !!,"Beginning date can not be after today's date.",! G ENT
S BEGDATE=Y
S DIR(0)="DO",DIR("A")="Ending date",DIR("B")=ENDDT
D ^DIR
;Q:Y?1."^" 1
I $D(DTOUT)!$D(DUOUT) Q 1
W " ("_$$FMTE^XLFDT(Y)_")" H 1
S ENDDATE=Y
I (ENDDATE<BEGDATE)!(ENDDATE>NOW) W !!,"End date can not be before beginning date or after today's date.",! K BEGDATE,ENDDATE G ENT
;PRXM/HC/BHS - 9/27/2005 - Remove conversion to $H format
;S BEGDATE=+$$FMTH^XLFDT(BEGDATE),ENDDATE=+$$FMTH^XLFDT(ENDDATE)
;I Y'=0 S BEGDATE=+$$FMTH^XLFDT(BEGDATE),ENDDATE=+$$FMTH^XLFDT(ENDDATE)
Q 0_U_SEL
PROMPT2(PAR,OPTS,OPTA,HELP) ;EP
N OPTNUM
K BEGDATE,ENDDATE,HIVTAX
S HIVTAX=1,ENDDATE=DT,BEGDATE=ENDDATE-10000
S ENDDT=$$FMTE^XLFDT(ENDDATE),BEGDT=$$FMTE^XLFDT(BEGDATE)
K DIR
S OPTNUM=0,DIR(0)=$S($G(OPTS(1))="":PAR,$G(OPTS(1))'="":PAR_"^",1:PAR_"^"),DIR("A")=OPTA,ERR=0
I $G(HELP)'="" S DIR("?")=HELP
F S OPTNUM=$O(OPTS(OPTNUM)) Q:OPTNUM=""!(ERR) D
.S OPTTEXT=$G(OPTS(OPTNUM))
.I $L(DIR(0))+$L(OPTNUM)+$L(OPTTEXT)+2>245 S ERR=1 Q
.S DIR(0)=DIR(0)_OPTNUM_":"_OPTTEXT_";"
I ERR Q "^"
D ^DIR
K DIR
Q Y
;
DATEPRMP() ;
S %DT="AEPX",%DT("A")="Enter Beginning Date: "
D ^%DT
Q:Y'>0 0
S BEGDATE=+Y W " ("_$$FMTE^XLFDT(Y)_")"
S %DT("A")="Enter Ending Date: "
D ^%DT
Q:Y'>0 0
S ENDDATE=+Y
K %DT
Q 1
;
DX(PROMPT,MULT) ; EP - Prompt for dx
; PROMPT - Optional - if it exists will replace DIR("A")
; MULT - Optional - 0/1 if 1 - loop for multiple selection, else singular
N DIR,STOP,DXFLTR,X,Y,VALS,II,CODES,DXDESC,DUOUT,DTOUT,NVALS
S STOP=0,(DXFLTR,DXDESC)="",VALS=$P($G(^DD(90451.01,2.3,0)),U,3)
; Translate E* codes to other mnemonics per IHS - Tucson 9/9/2005
; EI = IN, EU = UNK, EO = OCC, EN = NON
; Build code list
S CODES=""
F II=1:1:$L(VALS,";")-1 S CODES=CODES_","_$P($P(VALS,";",II),":",1)
; Update NVALS to reflect the display values
S NVALS=""
F II=1:1:$L(VALS,";")-1 D
. S CODE=$P($P(VALS,";",II),":",1),DESC=$P($P(VALS,";",II),":",2)
. S CODE=$S(CODE="EU":"UNK",CODE="EI":"IN",CODE="EN":"NON",CODE="EO":"OCC",1:CODE)
. S NVALS=$S(NVALS="":CODE_":"_DESC_";",1:NVALS_CODE_":"_DESC_";")
S DIR("A")=$S($G(PROMPT)'="":$G(PROMPT),1:"Select Register Diagnosis")
S DIR("B")="ALL"
F D Q:STOP!(DXFLTR="^")!('+$G(MULT))
.K X,Y
.;S DIR(0)="SO^"_VALS_"ALL:ALL"
.S DIR(0)="SO^"_NVALS_"ALL:ALL"
.I DXFLTR'="" K DIR("B") S DIR("A")=$S($G(PROMPT)'="":$G(PROMPT),1:"Select Another Register Diagnosis")
.D ^DIR
.I $D(DTOUT)!$D(DUOUT) S DXFLTR="^" Q
.I (Y="")&(DXFLTR="") S DXFLTR="^" Q
.I (Y="")&(DXFLTR'="") S STOP=1 Q
.; ALL
.I Y="ALL" S DXFLTR=CODES,DXDESC="ALL",STOP=1 Q
.I (DXFLTR_",")'[(","_$S(Y="UNK":"EU",Y="IN":"EI",Y="OCC":"EO",Y="NON":"EN",1:Y)_",") D
..S DXFLTR=DXFLTR_","_$S(Y="UNK":"EU",Y="IN":"EI",Y="OCC":"EO",Y="NON":"EN",1:Y)
..S DXDESC=$S(DXDESC'="":DXDESC_","_$S(Y(0)?1"AT RISK".E:"AT RISK-"_Y,1:Y(0)),1:$S(Y(0)?1"AT RISK".E:"AT RISK-"_Y,1:Y(0)))
..; Update desc if user has selected all one at a time
..I $L(DXFLTR,",")=$L(CODES,",") S DXDESC="ALL",STOP=1 Q
..; Update selection list to indicate (SELECTED)
..;F II=1:1:$L(VALS,";")-1 I $P($P(VALS,";",II),":",1)=Y S $P(VALS,";",II)=Y_":"_$P($P(VALS,";",II),":",2)_" (SELECTED)"
..F II=1:1:$L(NVALS,";")-1 I $P($P(NVALS,";",II),":",1)=Y S $P(NVALS,";",II)=Y_":"_$P($P(NVALS,";",II),":",2)_" (SELECTED)"
Q $S(DXFLTR'="^":DXFLTR_","_U_DXDESC,1:"^")
;
BKMIXX4 ;PRXM/HC/CJS - IEN LOOKUP UTILITIES ; 05 Aug 2005 1:55 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
IMM(BKMN,XACT) ;IMMUNIZATION NAME TO IEN
+1 ;The variable BKMN, which is the name of the immunization is
+2 ;passed into the subroutine. This may be passed as a number or an
+3 ;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
+4 ;If more than one IEN can be applied, an array called BKMIENX is
+5 ;created to contain all of the applicable IENs.
+6 KILL BKMIEN,BKMIENX,BKMN1
+7 IF $GET(XACT)=1
Begin DoDot:1
+8 SET BKMIEN=$ORDER(^AUTTIMM("B",BKMN,0))
+9 QUIT
End DoDot:1
+10 IF BKMN?1.N
Begin DoDot:1
+11 SET BKMIEN=$SELECT('$DATA(^AUTTIMM(BKMN)):-1,1:BKMN)
+12 QUIT
End DoDot:1
+13 IF BKMN'?1.N
Begin DoDot:1
+14 SET BKMN1=$EXTRACT(BKMN,1,($LENGTH(BKMN)-1))
+15 FOR
SET BKMN1=$ORDER(^AUTTIMM("B",BKMN1))
IF BKMN1=""!($EXTRACT(BKMN1,1,$LENGTH(BKMN))'=BKMN)
QUIT
Begin DoDot:2
+16 SET BKMIEN=$ORDER(^AUTTIMM("B",BKMN1,0))
SET BKMIENX(BKMIEN)=""
SET BKMIENX=$GET(BKMIENX)+1
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT $SELECT(BKMIENX>1:0,1:BKMIEN)
+19 ;
+20 ;
LAB(BKMN,XACT) ;LABORATORY TEST NAME TO IEN
+1 ;The variable BKMN, which is the name of the lab test is
+2 ;passed into the subroutine. This may be passed as a number or an
+3 ;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
+4 ;If more than one IEN can be applied, an array called BKMIENX is
+5 ;created to contain all of the applicable IENs.
+6 KILL BKMIEN,BKMIENX
+7 IF XACT=1
Begin DoDot:1
+8 SET BKMIEN=$ORDER(^LAB(60,"B",BKMN,0))
+9 QUIT
End DoDot:1
+10 IF BKMN?1.N
Begin DoDot:1
+11 SET BKMIEN=$SELECT('$DATA(^LAB(60,BKMN)):-1,1:BKMN)
+12 QUIT
End DoDot:1
+13 IF BKMN'?1.N
Begin DoDot:1
+14 SET BKMN1=$EXTRACT(BKMN,1,($LENGTH(BKMN)-1))
+15 FOR
SET BKMN1=$ORDER(^LAB(60,"B",BKMN1))
IF BKMN1=""!($EXTRACT(BKMN1,1,$LENGTH(BKMN))'=BKMN)
QUIT
Begin DoDot:2
+16 SET BKMIEN=$ORDER(^LAB(60,"B",BKMN1,0))
SET BKMIENX(BKMIEN)=""
SET BKMIENX=$GET(BKMIENX)+1
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT $SELECT(BKMIENX>1:0,1:BKMIEN)
+19 ;
LOINC(BKMN) ;LABORATORY TEST LOINC TO IEN
+1 ;The variable BKMN, which is the LOINC number of the lab test is
+2 ;passed into the subroutine. This may be passed as a number or an
+3 ;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
+4 ;If more than one IEN can be applied, an array called BKMIENX is
+5 ;created to contain all of the applicable IENs.
+6 KILL BKMIEN,BKMIENX
IF BKMN?1.N
Begin DoDot:1
+7 SET BKMIEN=$SELECT('$DATA(^LAB(60,"AF",BKMN,0)):-1,1:$ORDER(^LAB(60,"AF",BKMN,0)))
+8 QUIT
End DoDot:1
+9 IF BKMN'?1.N
Begin DoDot:1
+10 SET BKMN1=$EXTRACT(BKMN,1,($LENGTH(BKMN)-1))
+11 FOR
SET BKMN1=$ORDER(^LAB(60,"AF",BKMN1))
IF BKMN1=""!($EXTRACT(BKMN1,1,$LENGTH(BKMN))'=BKMN)
QUIT
Begin DoDot:2
+12 SET BKMIEN=$ORDER(^LAB(60,"AF",BKMN1,0))
SET BKMIENX(BKMIEN)=""
SET BKMIENX=$GET(BKMIENX)+1
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT $SELECT(BKMIENX>1:0,1:BKMIEN)
+15 ;
MEDS(BKMN,XACT) ;DRUG NAME TO IEN
+1 ;The variable BKMN, which is the name of the medication is
+2 ;passed into the subroutine. This may be passed as a number or an
+3 ;alpha/numeric. And the variable BKMIEN, which is the IEN is returned.
+4 ;If more than one IEN can be applied, an array called BKMIENX is
+5 ;created to contain all of the applicable IENs.
+6 KILL BKMIEN,BKMIENX
+7 IF XACT=1
Begin DoDot:1
+8 SET BKMIEN=$ORDER(^PSDRUG("B",BKMN,0))
+9 QUIT
End DoDot:1
+10 IF BKMN?1.N
Begin DoDot:1
+11 SET BKMIEN=$SELECT('$DATA(^PSDRUG(BKMN)):-1,1:BKMN)
+12 QUIT
End DoDot:1
+13 IF BKMN'?1.N
Begin DoDot:1
+14 SET BKMN1=$EXTRACT(BKMN,1,($LENGTH(BKMN)-1))
+15 FOR
SET BKMN1=$ORDER(^PSDRUG("B",BKMN1))
IF BKMN1=""!($EXTRACT(BKMN1,1,$LENGTH(BKMN))'=BKMN)
QUIT
Begin DoDot:2
+16 SET BKMIEN=$ORDER(^PSDRUG("B",BKMN1,0))
SET BKMIENX(BKMIEN)=""
SET BKMIENX=$GET(BKMIENX)+1
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT $SELECT(BKMIENX>1:0,1:BKMIEN)
BMI(X,Y) ;Calculate Body Mass Index
+1 ;The variable X is the weight in pounds
+2 ;The variable Y is the height in inches
+3 NEW BKMBMI
+4 SET BKMBMI=(X/(Y*Y))*703
SET BKMBMI=(BKMBMI*10)\1/10
+5 QUIT BKMBMI
+6 ; This routine will pad a variable in the front or back, using
+7 ; any character that you specify; to the desired length.
+8 ; VAR is the string of characters that you would like to pad.
+9 ; FB indicates if you want to pad at the front or back of the string VAR.
+10 ; An FB value of "<" indicates that you want to pad at the front.
+11 ; An FB value of ">" indicates that you want to pad at the back.
+12 ; CHAR indicates the character that you want to use to pad the variable VAR with.
+13 ; LEN indicates the length that you want to pad the variable VAR to.
+14 ;
+15 ; The value is returned extrinsically.
PAD(VAR,FB,CHAR,LEN) ;EP
+1 NEW PAD
+2 SET $PIECE(PAD,CHAR,LEN+1)=""
+3 IF $LENGTH(VAR)>LEN
QUIT $EXTRACT(VAR,1,LEN)
+4 IF FB="<"
QUIT $EXTRACT(PAD,1,LEN-$LENGTH(VAR))_VAR
+5 IF FB=">"
QUIT VAR_$EXTRACT(PAD,1,LEN-$LENGTH(VAR))
+6 QUIT $EXTRACT(VAR,1,LEN)
PROMPT(PAR,OPTS,OPTA,FIRST,SECOND) ;EP
+1 ; INPUT
+2 ; PAR - Parameter for piece 1 of DIR(0)
+3 ; OPTS - Array passed by reference containing the option names that
+4 ; ^DIR will display
+5 ; OPTA - DIR("A") value for prompt to user
+6 ; FIRST - Do we execute the first prompt? $$PROMPT^BKMIXX4
+7 ; SECOND - Do we execute the second prompt?
ENT NEW STOP
+1 SET STOP=0
+2 IF FIRST
Begin DoDot:1
+3 SET Y=$$PROMPT2^BKMIXX4(PAR,.OPTS,OPTA)
+4 IF $GET(Y)?1."^"!('$GET(Y))!($GET(Y)<0)
SET Y=-1
SET STOP=1
End DoDot:1
+5 IF STOP
QUIT 1_U_Y
+6 SET SEL=Y
+7 SET HIVTAX=$SELECT(Y=1:1,1:0)
+8 IF 'SECOND
QUIT 0_U_SEL
+9 IF 'FIRST
Begin DoDot:1
+10 SET HIVTAX=0
SET ENDDATE=DT
SET BEGDATE=ENDDATE-10000
+11 SET ENDDT=$$FMTE^XLFDT(ENDDATE)
SET BEGDT=$$FMTE^XLFDT(BEGDATE)
End DoDot:1
+12 SET DIR(0)="DO"
SET DIR("A")="Beginning date"
SET DIR("B")=BEGDT
+13 DO ^DIR
+14 ;Q:Y?1."^" 1
+15 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 1
+16 WRITE " ("_$$FMTE^XLFDT(Y)_")"
HANG 1
+17 SET NOW=$PIECE($$NOW^XLFDT,".")
+18 IF (Y>NOW)
WRITE !!,"Beginning date can not be after today's date.",!
GOTO ENT
+19 SET BEGDATE=Y
+20 SET DIR(0)="DO"
SET DIR("A")="Ending date"
SET DIR("B")=ENDDT
+21 DO ^DIR
+22 ;Q:Y?1."^" 1
+23 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 1
+24 WRITE " ("_$$FMTE^XLFDT(Y)_")"
HANG 1
+25 SET ENDDATE=Y
+26 IF (ENDDATE<BEGDATE)!(ENDDATE>NOW)
WRITE !!,"End date can not be before beginning date or after today's date.",!
KILL BEGDATE,ENDDATE
GOTO ENT
+27 ;PRXM/HC/BHS - 9/27/2005 - Remove conversion to $H format
+28 ;S BEGDATE=+$$FMTH^XLFDT(BEGDATE),ENDDATE=+$$FMTH^XLFDT(ENDDATE)
+29 ;I Y'=0 S BEGDATE=+$$FMTH^XLFDT(BEGDATE),ENDDATE=+$$FMTH^XLFDT(ENDDATE)
+30 QUIT 0_U_SEL
PROMPT2(PAR,OPTS,OPTA,HELP) ;EP
+1 NEW OPTNUM
+2 KILL BEGDATE,ENDDATE,HIVTAX
+3 SET HIVTAX=1
SET ENDDATE=DT
SET BEGDATE=ENDDATE-10000
+4 SET ENDDT=$$FMTE^XLFDT(ENDDATE)
SET BEGDT=$$FMTE^XLFDT(BEGDATE)
+5 KILL DIR
+6 SET OPTNUM=0
SET DIR(0)=$SELECT($GET(OPTS(1))="":PAR,$GET(OPTS(1))'="":PAR_"^",1:PAR_"^")
SET DIR("A")=OPTA
SET ERR=0
+7 IF $GET(HELP)'=""
SET DIR("?")=HELP
+8 FOR
SET OPTNUM=$ORDER(OPTS(OPTNUM))
IF OPTNUM=""!(ERR)
QUIT
Begin DoDot:1
+9 SET OPTTEXT=$GET(OPTS(OPTNUM))
+10 IF $LENGTH(DIR(0))+$LENGTH(OPTNUM)+$LENGTH(OPTTEXT)+2>245
SET ERR=1
QUIT
+11 SET DIR(0)=DIR(0)_OPTNUM_":"_OPTTEXT_";"
End DoDot:1
+12 IF ERR
QUIT "^"
+13 DO ^DIR
+14 KILL DIR
+15 QUIT Y
+16 ;
DATEPRMP() ;
+1 SET %DT="AEPX"
SET %DT("A")="Enter Beginning Date: "
+2 DO ^%DT
+3 IF Y'>0
QUIT 0
+4 SET BEGDATE=+Y
WRITE " ("_$$FMTE^XLFDT(Y)_")"
+5 SET %DT("A")="Enter Ending Date: "
+6 DO ^%DT
+7 IF Y'>0
QUIT 0
+8 SET ENDDATE=+Y
+9 KILL %DT
+10 QUIT 1
+11 ;
DX(PROMPT,MULT) ; EP - Prompt for dx
+1 ; PROMPT - Optional - if it exists will replace DIR("A")
+2 ; MULT - Optional - 0/1 if 1 - loop for multiple selection, else singular
+3 NEW DIR,STOP,DXFLTR,X,Y,VALS,II,CODES,DXDESC,DUOUT,DTOUT,NVALS
+4 SET STOP=0
SET (DXFLTR,DXDESC)=""
SET VALS=$PIECE($GET(^DD(90451.01,2.3,0)),U,3)
+5 ; Translate E* codes to other mnemonics per IHS - Tucson 9/9/2005
+6 ; EI = IN, EU = UNK, EO = OCC, EN = NON
+7 ; Build code list
+8 SET CODES=""
+9 FOR II=1:1:$LENGTH(VALS,";")-1
SET CODES=CODES_","_$PIECE($PIECE(VALS,";",II),":",1)
+10 ; Update NVALS to reflect the display values
+11 SET NVALS=""
+12 FOR II=1:1:$LENGTH(VALS,";")-1
Begin DoDot:1
+13 SET CODE=$PIECE($PIECE(VALS,";",II),":",1)
SET DESC=$PIECE($PIECE(VALS,";",II),":",2)
+14 SET CODE=$SELECT(CODE="EU":"UNK",CODE="EI":"IN",CODE="EN":"NON",CODE="EO":"OCC",1:CODE)
+15 SET NVALS=$SELECT(NVALS="":CODE_":"_DESC_";",1:NVALS_CODE_":"_DESC_";")
End DoDot:1
+16 SET DIR("A")=$SELECT($GET(PROMPT)'="":$GET(PROMPT),1:"Select Register Diagnosis")
+17 SET DIR("B")="ALL"
+18 FOR
Begin DoDot:1
+19 KILL X,Y
+20 ;S DIR(0)="SO^"_VALS_"ALL:ALL"
+21 SET DIR(0)="SO^"_NVALS_"ALL:ALL"
+22 IF DXFLTR'=""
KILL DIR("B")
SET DIR("A")=$SELECT($GET(PROMPT)'="":$GET(PROMPT),1:"Select Another Register Diagnosis")
+23 DO ^DIR
+24 IF $DATA(DTOUT)!$DATA(DUOUT)
SET DXFLTR="^"
QUIT
+25 IF (Y="")&(DXFLTR="")
SET DXFLTR="^"
QUIT
+26 IF (Y="")&(DXFLTR'="")
SET STOP=1
QUIT
+27 ; ALL
+28 IF Y="ALL"
SET DXFLTR=CODES
SET DXDESC="ALL"
SET STOP=1
QUIT
+29 IF (DXFLTR_",")'[(","_$SELECT(Y="UNK":"EU",Y="IN":"EI",Y="OCC":"EO",Y="NON":"EN",1:Y)_",")
Begin DoDot:2
+30 SET DXFLTR=DXFLTR_","_$SELECT(Y="UNK":"EU",Y="IN":"EI",Y="OCC":"EO",Y="NON":"EN",1:Y)
+31 SET DXDESC=$SELECT(DXDESC'="":DXDESC_","_$SELECT(Y(0)?1"AT RISK".E:"AT RISK-"_Y,1:Y(0)),1:$SELECT(Y(0)?1"AT RISK".E:"AT RISK-"_Y,1:Y(0)))
+32 ; Update desc if user has selected all one at a time
+33 IF $LENGTH(DXFLTR,",")=$LENGTH(CODES,",")
SET DXDESC="ALL"
SET STOP=1
QUIT
+34 ; Update selection list to indicate (SELECTED)
+35 ;F II=1:1:$L(VALS,";")-1 I $P($P(VALS,";",II),":",1)=Y S $P(VALS,";",II)=Y_":"_$P($P(VALS,";",II),":",2)_" (SELECTED)"
+36 FOR II=1:1:$LENGTH(NVALS,";")-1
IF $PIECE($PIECE(NVALS,";",II),":",1)=Y
SET $PIECE(NVALS,";",II)=Y_":"_$PIECE($PIECE(NVALS,";",II),":",2)_" (SELECTED)"
End DoDot:2
End DoDot:1
IF STOP!(DXFLTR="^")!('+$GET(MULT))
QUIT
+37 QUIT $SELECT(DXFLTR'="^":DXFLTR_","_U_DXDESC,1:"^")
+38 ;
