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

BKMIXX4.m

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