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

BKMIXX3.m

Go to the documentation of this file. 
  1. BKMIXX3 ;PRXM/HC/CJS - BKMI UTILITY PROGRAM; [ 1/19/2005  7:16 PM ] ; 21 Jul 2005  12:00 PM
  1.  ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;Miscellaneous BKM utilities
  1.  ; Daou Incorporated v 1.0
  1.  ; 4/12/05 - WOM
  1.  Q
  1. I(BKMVAR,BKMINC) ;EP - Returns BKMVAR+BKMINC while updating BKMVAR
  1.  ; Programmers note: This function is meant to mimic the $I
  1.  ;    function of CACHE 5. In order to fully mimic that function,
  1.  ;    the first argument must be passed by reference.
  1.  ;    No compatibility with the $I function is guaranteed unless
  1.  ;    this the first argument is called by reference. In fact, null values
  1.  ;    for the first argument are allowed if not passed by reference,
  1.  ;    unlike $I.
  1.  N BKMJUNK
  1.  S BKMJUNK=$D(BKMINC)
  1.  I $E(BKMJUNK,$L(BKMJUNK))'=1 S BKMINC=1
  1.  I $G(BKMVAR)="" S BKMVAR=0
  1.  S BKMVAR=BKMVAR+BKMINC
  1.  Q BKMVAR
  1.  ;
  1. BASETMP(DFN) ; EP - Create ^TMP("BKMLKP",$J) entries
  1.  ; Extrinsic function - Returns 1 (success = global created) or
  1.  ;                              0 (failure = nothing created)
  1.  ; Input:
  1.  ;  DFN - IEN for File 2 (Patient)
  1.  ; Output:
  1.  ;  BKMIEN - IEN for File 90451 (HMS Registry)
  1.  ;  ^TMP("BKMLKP",$J)=DFN
  1.  ;  ^TMP("BKMLKP",$J,DFN)=PatientName^HRN^DOB(internal)^Sex(internal)^Age(calculated)^MaritalStatus(internal)^IEN(File 90451)
  1.  ; Initialize
  1.  N DA,PNT,HRN,DOB,SEX,AGE,MSTAT
  1.  I '$D(DFN) Q 0
  1.  I DFN="" Q 0
  1.  ; Get IEN from File 90451 based on DFN
  1.  S (DA,BKMIEN)=$O(^BKM(90451,"B",DFN,0))
  1.  S PNT=$$GET1^DIQ(2,DFN,.01,"I")   ; Patient Name
  1.  S HRN=$$HRN^BKMVA1(DFN)           ; HRN
  1.  S DOB=$$GET1^DIQ(2,DFN,.03,"I")   ; DOB
  1.  S SEX=$$GET1^DIQ(2,DFN,.02,"I")   ; Sex
  1.  S AGE=$$AGE^BKMIMRP1(DFN)         ; Age
  1.  S MSTAT=$$GET1^DIQ(2,DFN,.05,"I") ; Marital Status
  1.  K ^TMP("BKMLKP",$J)
  1.  S ^TMP("BKMLKP",$J,DFN)=PNT_U_HRN_U_DOB_U_SEX_U_AGE_U_MSTAT_U_DA
  1.  S ^TMP("BKMLKP",$J)=DFN
  1.  Q 1
  1.  ;
  1. NOGO ;EP - NOT ALLOWED TO CHANGED OR ENTER DATA
  1.  ;PRXM/HC/CJS 07/21/2005 -- Updated prompt
  1.  ;W !!,*7,"Sorry, you are not authorized to enter/edit data at this point.",! H 2
  1.  W !!,*7,"Sorry, you are not currently authorized to modify patient data.",!,"Please see your Security Administrator for access.",! H 4
  1.  Q
  1.  ;
  1. PAUSE(PROMPT) ;EP - For screen displays pause and allow user to stop
  1.  ; Returns a 1 if the user elected to stop
  1.  I IOST'["C-" Q 0
  1.  N DIR,DTOUT,DUOUT
  1.  I $G(PROMPT)]"" S DIR("A")=PROMPT
  1.  S DIR(0)="E" D ^DIR
  1.  Q $D(DTOUT)!$D(DUOUT)
  1.  ;
  1. HIVIEN() ; EP - Return IEN of HIV from File 90450
  1.  ; Extrinsic function - returns IEN (File 90450 for HIV) or
  1.  ;                              ""  (File 90450 for HIV not found)
  1.  ; Input:  n/a
  1.  ; Output: n/a
  1.  ; Initialize
  1.  N BKMHIV,DA
  1.  S BKMHIV=$O(^BKM(90450,"B","HMS REGISTER",""))
  1.  S DA=BKMHIV
  1.  Q BKMHIV
  1.  ;
  1. VALID(BKMDUZ) ; EP - Determine if user is permitted in the HMS registry
  1.  ; Extrinsic function - returns 1 (success - user in HMS registry) or
  1.  ;                              0 (failure - user not in HMS registry)
  1.  ; Input:
  1.  ;  BKMDUZ - DUZ, IEN for File 200
  1.  ; Output: n/a
  1.  ; Initialize
  1.  N BKMVLD,BKMHIV
  1.  S BKMVLD=0
  1.  S BKMHIV=$$HIVIEN^BKMIXX3()
  1.  ; Determine if user's DUZ is in the HIV registry x-ref
  1.  I BKMHIV'="",$G(BKMDUZ)'="",$D(^BKM(90450,BKMHIV,11,"B",$G(BKMDUZ))) S BKMVLD=1
  1.  Q BKMVLD
  1.  ;
  1. BKMIEN(BKMDFN) ; EP - Determine IEN for Patient in File 90451 based on DFN
  1.  ; Extrinsic function - returns IEN (File 90451 IEN for DFN) or
  1.  ;                              ""  (No File 90451 entry for DFN)
  1.  ; Input:
  1.  ;  BKMDFN - IEN for Patient File 2
  1.  ; Output: n/a
  1.  ; Initialize
  1.  N BKMIEN
  1.  S BKMIEN=$S($G(BKMDFN)'="":$O(^BKM(90451,"B",$G(BKMDFN),"")),1:"")
  1.  Q BKMIEN
  1.  ;
  1. BKMREG(BKMIEN) ; EP - Determine IEN for HIV registry in File 90451.01 based on File 90451 IEN
  1.  ; Extrinsic function - returns IEN (File 90451.01 IEN for HIV) or
  1.  ;                              ""  (No File 90451.01 entry for HIV)
  1.  ; Input:
  1.  ;  BKMIEN - IEN for File 90451
  1.  ; Output: n/a
  1.  ; Initialize
  1.  N BKMHIV,BKMREG
  1.  S BKMREG=""
  1.  S BKMHIV=$$HIVIEN^BKMIXX3()
  1.  I BKMHIV'="",$G(BKMIEN)'="" S BKMREG=$O(^BKM(90451,$G(BKMIEN),1,"B",BKMHIV,""))
  1.  Q BKMREG
  1.  ;
  1. BKMPRIV(BKMDUZ) ; EP - Determine user's rights in HMS
  1.  ; Extrinsic function - returns 1 (ability to add/edit) or
  1.  ;                              0 (not permitted to add/edit)
  1.  ; Input:
  1.  ;  BKMDUZ - DUZ, IEN for File 200
  1.  ; Output: n/a
  1.  ; Initialize
  1.  N BKMHIV,BKMPRV,BKMPRIV
  1.  S BKMPRIV=""
  1.  S BKMHIV=$$HIVIEN^BKMIXX3()
  1.  I BKMHIV'="",$G(BKMDUZ)'="" D
  1.  . S BKMPRV=$O(^BKM(90450,BKMHIV,11,"B",$G(BKMDUZ),0))
  1.  . I BKMPRV'="" S BKMPRIV=$P(^BKM(90450,BKMHIV,11,BKMPRV,0),"^",2)
  1.  S BKMPRIV=$S(BKMPRIV="":0,BKMPRIV="R":0,1:1)
  1.  Q BKMPRIV
  1.  ;
  1. HDR ; EP - Display header for menus
  1.  N PKG,VERSION,DA,IENS,SITE,USER
  1.  S PKG=$$FIND1^DIC(9.4,,"X","BKM","C")
  1.  S VERSION=$$GET1^DIQ(9.4,PKG,13,"I"),VERSION="HMS Version "_VERSION
  1.  S DA=$G(DUZ(2)),IENS=$$IENS^DILF(.DA),SITE=$$GET1^DIQ(4,IENS,.01,"E")
  1.  S USER="Current User: "_$$GET1^DIQ(200,$G(DUZ),.01,"I")
  1.  W @IOF,!!?IOM-$L(VERSION)\2,VERSION
  1.  W !?IOM-$L(SITE)\2,SITE
  1.  W !?IOM-$L(USER)\2,USER
  1.  Q
  1.  ;
  1. DIAG(DEF,RECVAL,MIX) ;EP - HMS Diagnosis Category
  1.  ; Prompt user for HMS Diagnosis Category
  1.  ; A tiered approach was requested by IHS.
  1.  ; At risk -> Exposed Source Known -> Specific Source
  1.  ; User may enter final value and bypass prompts
  1.  ; e.g. EI may be entered at the HMS DIAGNOSIS CATEGORY prompt
  1.  ; DEF = the current HMS Diagnosis Category in 90451
  1.  ; RECVAL = recommended value
  1.  ; MIX = mixed case flag (used by input template BKMV PATIENT RECORD
  1.  ; 
  1.  N DIR,Y
  1.  S DEF=$G(DEF),MIX=$G(MIX)
  1. DI1 S DIR(0)="F"
  1.  K DIR("A")
  1.  S DIR("A")=$S(MIX:"  HMS Diagnosis Category",1:"HMS DIAGNOSIS CATEGORY")
  1.  S DIR("A",1)=" "
  1.  S DIR("A",2)="     Select one of the following:"
  1.  S DIR("A",3)=" "
  1.  S DIR("A",4)="          R         AT RISK"
  1.  S DIR("A",5)="          H         HIV"
  1.  S DIR("A",6)="          A         AIDS"
  1.  S DIR("A",7)=" "
  1.  K DIR("B")
  1.  I DEF]"" D
  1.  . I DEF="A"!(DEF="H") S DIR("B")=$S(DEF="A":"AIDS",1:"HIV") Q
  1.  . S DIR("B")="AT RISK"
  1.  . ;I DEF="A"!(DEF="H") S DIR("B")=DEF Q
  1.  . ;S DIR("B")="R"
  1.  ;If there is no Diagnosis Category on file and there is a recommended value display it
  1.  I DEF="",RECVAL]"" S DIR("A",9)="  Recommended Diagnosis Value = <"_$S(RECVAL="A":"AIDS",1:"HIV")_">"
  1.  S DIR("?")="Enter a code from the list."
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT) Q -1
  1.  ; Convert response from lower to upper case
  1.  S Y=$$UP^XLFSTR(Y)
  1.  ; If 1st character of response is an 'A' distinguish between AIDS, AT RISK and Invalid entry
  1.  I $E(Y)="A",$E("AIDS",1,$L(Y))'=Y S Y=$S($E("AT RISK-",1,$L(Y))=Y:"R",1:"Invalid")
  1.  S Y=$E(Y)
  1.  I '$F("^R^H^A^",U_Y_U) W !!?2,"Enter a code from the list.",!! G DI1
  1.  W " ",$S(Y="R":"AT RISK",Y="H":"HIV",1:"AIDS")
  1.  I Y'="R" Q $$DICONV(Y)
  1. DI2 ; At-Risk Level
  1.  ; PRX/HMS/DLS 3/30/2006 Changed DIR(0) from 'F'ree text to 'S'et of Codes.
  1.  S DIR(0)="Fr"
  1.  K DIR("A")
  1.  S DIR("A")=$S(MIX:"  At Risk Diagnosis Category",1:"AT RISK DIAGNOSIS CATEGORY")
  1.  S DIR("A",1)=" "
  1.  S DIR("A",2)="     Select one of the following:"
  1.  S DIR("A",3)=" "
  1.  S DIR("A",4)="          KN         AT RISK- KNOWN SOURCE"
  1.  S DIR("A",5)="          UNK        AT RISK- UNKNOWN SOURCE"
  1.  S DIR("A",6)=" "
  1.  K DIR("B")
  1.  I DEF]"" D
  1.  . I DEF="A"!(DEF="H") Q
  1.  . I DEF="EU" S DIR("B")="AT RISK- UNKNOWN SOURCE" Q
  1.  . S DIR("B")="AT RISK- KNOWN SOURCE"
  1.  . ;I DEF="EU" S DIR("B")="UNK" Q
  1.  . ;S DIR("B")="KN"
  1.  S DIR("?")="Enter a code from the list."
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT) Q -1
  1.  S Y=$$UP^XLFSTR(Y)
  1.  I $L(Y)>9,$E("AT RISK- KNOWN SOURCE",1,$L(Y))=Y S Y="KN"
  1.  I $L(Y)>9,$E("AT RISK- UNKNOWN SOURCE",1,$L(Y))=Y S Y="UNK"
  1.  S Y=$S((Y="K")!(Y="KN"):"KN",(Y="U")!(Y="UN")!(Y="UNK"):"UNK",1:"")
  1.  I '$F("^KN^UNK^",U_Y_U) W !!?2,"Enter a code from the list.",!! G DI2
  1.  W " ",$S(Y="KN":"AT RISK- KNOWN SOURCE",1:"AT RISK- UNKNOWN SOURCE")
  1.  I Y="UNK" Q "EU"
  1. DI3 ; At Risk - Known Level
  1.  S DIR(0)="Fr"
  1.  K DIR("A")
  1.  S DIR("A")=$S(MIX:"  At Risk- Known Source Diagnosis Category",1:"AT RISK- KNOWN SOURCE DIAGNOSIS CATEGORY")
  1.  S DIR("A",1)=" "
  1.  S DIR("A",2)="     Select one of the following:"
  1.  S DIR("A",3)=" "
  1.  S DIR("A",4)="          IN         AT RISK- INFANT EXPOSED"
  1.  S DIR("A",5)="          OCC        AT RISK- OCCUPATIONAL EXPOSURE"
  1.  S DIR("A",6)="          NON        AT RISK- NON OCCUPATIONAL EXPOSURE"
  1.  S DIR("A",7)=" "
  1.  K DIR("B")
  1.  I DEF]"" D
  1.  . I DEF="A"!(DEF="H")!(DEF="EU") Q
  1.  . S DIR("B")=$S(DEF="EI":"AT RISK- INFANT EXPOSED",DEF="EO":"AT RISK- OCCUPATIONAL EXPOSURE",DEF="EN":"AT RISK- NON OCCUPATIONAL EXPOSURE",1:"")
  1.  S DIR("?")="Enter a code from the list to identify the type of exposure."
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT) Q -1
  1.  S Y=$$UP^XLFSTR(Y)
  1.  I $L(Y)>9,$E("AT RISK- INFANT EXPOSED",1,$L(Y))=Y S Y="IN"
  1.  I $L(Y)>9,$E("AT RISK- OCCUPATIONAL EXPOSURE",1,$L(Y))=Y S Y="OCC"
  1.  I $L(Y)>9,$E("AT RISK- NON OCCUPATIONAL EXPOSURE",1,$L(Y))=Y S Y="NON"
  1.  S Y=$S((Y="I")!(Y="IN"):"IN",(Y="O")!(Y="OC")!(Y="OCC"):"OCC",(Y="N")!(Y="NO")!(Y="NON"):"NON",1:"")
  1.  I '$F("^IN^OCC^NON^",U_Y_U) W !!?2,"Enter a code from the list.",!! G DI3
  1.  W " ",$S(Y="IN":"AT RISK- INFANT EXPOSED",Y="OCC":"AT RISK- OCCUPATIONAL EXPOSURE",1:"AT RISK- NON OCCUPATIONAL EXPOSURE")
  1.  Q $$DICONV(Y)
  1.  ;
  1. DICONV(VAL) ;Convert external to internal value of HMS Diagnosis Category
  1.  Q $S(Y="NON":"EN",Y="OCC":"EO",Y="IN":"EI",Y="UNK":"EU",Y="KN":"EK",1:Y)