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