BKMVSUP ;PRXM/HC/WOM - HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:02 PM
;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
Q
;
EP(DFN) ;EP - Called by Health Summary Supplement
; Value for APCHSPAT is passed to identify the patient (DFN)
; IO variables will already have been set
N X,BKMIEN,DIR,DIRUT
S DFN=$G(DFN)
Q:DFN=""
K ^TMP("BKMSUPP",$J),^TMP("BKMVSUP",$J)
S X=$O(^BKM(90451,"B",DFN,""))
;I X="" S X=$$ATAG^BQITDUTL(DFN,"HIV/AIDS") I 'X S X=""
I X="" D:'$D(ZTQUEUED) Q
. ;W !!?5,"HMS Patient Care Summary is not available. This patient does not"
. ;W !?5,"have an active HIV diagnostic tag and/or is not in the HMS Register.",!
. W !!?5,"HMS Patient Care Summary cannot be generated as selected patient"
. W !?5,"is not in the HMS Register.",!
;
; Comment out the security check in the event that IHS reconsiders
; I '$$PRIV(DUZ) D Q
; . I $E(IOST)="C" D
; .. W !!,"Sorry, you are currently not an authorized HMS user."
; .. W !,"Please see your Security Administrator for access.",! H 2
;
S BKMIEN=X_U_DFN,^TMP("BKMSUPP",$J,"IENS")=BKMIEN
I $E(IOST)="C",IO=IO(0) D Q:$G(APCHSQIT)
. W !!
. S DIR("A")="HMS PATIENT CARE SUMMARY WILL NOW BE DISPLAYED (^ TO EXIT, RETURN TO CONTINUE)"
. S DIR(0)="E" D ^DIR
. I $D(DIRUT) S APCHSQIT=1 Q
N LINE,PGCNT,LNCNT
S (PGCNT,LNCNT)=1
D EP2(DFN)
D PRINT
W @IOF K Y
K ^TMP("BKMSUPP",$J),^TMP("BKMVSUP",$J)
Q
;
EP2(DFN) ; Get data and report for one patient
; Store lines to print in ^TMP("BKMVSUP",$J)
N NOW,X,DA,Y,HLDBKM,AUPNPAT,AUDT,AUDATA,PTNAME,HRECNO,PAGES,BKMDT
S X=$O(^BKM(90451,"B",DFN,""))
;I X="" S X=$$ATAG^BQITDUTL(DFN,"HIV/AIDS") I 'X S X=""
I X="" D:'$D(ZTQUEUED) Q
. ;W !!?5,"HMS Patient Care Summary is not available. This patient does not"
. ;W !?5,"have an active HIV diagnostic tag and/or is not in the HMS Register.",!
. W !!?5,"HMS Patient Care Summary cannot be generated as selected patient"
. W !?5,"is not in the HMS Register.",!
S (DA,Y)=X,HLDBKM=X_U_DFN
K LOCAL,DIC,ICD9S
D NOW^%DTC S NOW=X
I +Y'<0 D GET^BKMVSRP1($P(HLDBKM,U)),GETDATA
K LOCAL,ICD9S,^TMP("BKMSUPP",$J)
Q
;
PRINT ; Print report from ^TMP("BKMVSUP",$J)
N PAGE,CNT,XNOW,QUIT
U IO
S PAGE="",CNT=""
S QUIT="" ; Used to identify if user wants to quit display if run to the screen
D NOW^%DTC S XNOW=$$FMTE^XLFDT(X,"5Z")
F S PAGE=$O(^TMP("BKMVSUP",$J,PAGE)) Q:'PAGE D Q:QUIT
. D HEADER^BKMVSUP6(PAGE,XNOW)
. F S CNT=$O(^TMP("BKMVSUP",$J,PAGE,CNT)) D Q:'CNT!QUIT
.. I 'CNT S QUIT=$$PAUSE^BKMVSUP3() Q
.. W !,^TMP("BKMVSUP",$J,PAGE,CNT)
I QUIT S APCHSQIT=1
Q
;
GETDATA ; Load data in ^TMP
;
N A,DPTIEN,BKMIEN,CLCL,RDIAG,GETSIENS,BKMREG,LSTDXDT,A1,I,J,K,L,BKMDT,TEMP,MAXCT,BKM,BKMT
N BMI,%H,DR,STCAT,STIEN,AGE,GLOBAL,CPRDT,CNT,CDDT,Y,CDTST,TYPE,BKMHAART,HIVDXDT,TMPDT
N HPRV,HCSM,DBMI
S MAXCT=IOSL-7
;
S DPTIEN=$P(^TMP("BKMSUPP",$J,"IENS"),U,2),BKMIEN=$P(^TMP("BKMSUPP",$J,"IENS"),U)
S GETSIENS=BKMIEN,DFN=DPTIEN
S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
;
; Array LOCAL is set up with the following subscripts:
; LOCAL(2,DPTIEN,.01,"I")=name
; LOCAL(2,DPTIEN,.01,"E")=name
; LOCAL(2,DPTIEN,.02,"I")=sex...e.g. F for female
; LOCAL(2,DPTIEN,.03,"I")=date of birth in internal format
; LOCAL(9000001,BKMIEN,1102.98)=age
; LOCAL(9000001,BKMIEN,1118)=community
; LOCAL(90451,BKMIEN,.02,"E")=name
; LOCAL(90451,BKMIEN,.02,"I")=DPTIEN
; LOCAL(90451.01,"1,"_BKMIEN_",",.5,"E")=STATUS
; LOCAL(90451.01,"1,"_BKMIEN_",",2.3,"E")=DIAGNOSIS CATEGORY
; LOCAL(90451.01,"1,"_BKMIEN_",",4.1,"E")=STATE HIV CONFIRMATION STATUS
; LOCAL(90451.01,"1,"_BKMIEN_",",4.2,"E")=STATE HIV CONFIRMATION DATE
; LOCAL(90451.01,"1,"_BKMIEN_",",4.51,"E")=STATE AIDS ACKNOWLEDGEMENT STATUS
; LOCAL(90451.01,"1,"_BKMIEN_",",4.52,"E")=STATE AIDS ACKNOWLEDGEMENT DATE
; LOCAL("HRECNO")=HEALTH RECORD NUMBER
; LOCAL(90451.01,"1,"_BKMIEN_",",.015,"E")=FACILITY(WHERE FOLLOWS)
;
S LINE=" Patient's Name: "_$E($G(LOCAL(2,DPTIEN,.01,"E")),1,30)
S LINE=$$LINE(LINE,"HRN: ",46)_$E($G(LOCAL("HRECNO")),1,8)
D UPD
S LINE=" Sex: "_$G(LOCAL(2,DPTIEN,.02,"I"))
S LINE=$$LINE(LINE,"DOB: ",19)
S Y=LOCAL(2,DPTIEN,.03,"I") S LINE=LINE_$$FMTE^XLFDT(Y,"5Z")
S AGE=$E($P($G(LOCAL(9000001,DPTIEN,1102.98))," "),1,3)
S LINE=$$LINE(LINE,"Age: ",46)_AGE_$E($P($G(LOCAL(9000001,DPTIEN,1102.98))," ",2),1)
D UPD
S RDIAG=$P($$DPCP^BQIULPT(DFN),U,2)
;S RDIAG=$$GET1^DIQ(9000001,DFN,.14,"E")
S LINE=" Designated Primary Care Provider: "_RDIAG
D UPD
K TEMP D GETS^DIQ(90451.01,1_","_+BKMIEN_",",".02;.5;.75;2;2.5;3;3.5;5;5.5;6;6.5","IE","TEMP")
S LINE=" HIV Provider: "
S HPRV=$$HPRV^BQIVFDEF(DFN) I HPRV S HPRV=$$GET1^DIQ(200,HPRV_",",.01,"E")
S LINE=LINE_HPRV
D UPD
S LINE=" HIV Case Manager: "
S HCSM=$$HCSM^BQIVFDEF(DFN) I HCSM S HCSM=$$GET1^DIQ(200,HCSM_",",.01,"E")
S LINE=LINE_HCSM
D UPD
S RDIAG=$$HTWT^BKMVSUP2(DFN)
S LINE=" Last Height: "_$P(RDIAG,U)_" "_$P(RDIAG,U,2)
N POS,LEN
S POS=30,LEN=$L(LINE) I LEN>28 S POS=LEN+2
S LINE=$$LINE(LINE," Last Weight: ",POS)_$P(RDIAG,U,3)_" "_$P(RDIAG,U,4)
D UPD
; Determine BMI
;S BMI=$$BMI(DFN,$P(RDIAG,U),$$DT($P(RDIAG,U,2)),$P(RDIAG,U,3),$$DT($P(RDIAG,U,4)),AGE)
S DBMI=$$PBMI^APCLV(DFN,DT)
S BMI=$P(DBMI,U,1)
I BMI'="" S BMI=$J(BMI,3,2)
; if BMI cannot be set display the following
I BMI="" S BMI="BMI cannot be calculated with current data. - "_$P(DBMI,U,8)
S LINE=" BMI: "_BMI
D UPD,BLANK(1)
S LINE=" Register Diagnosis: "_$G(LOCAL(90451.01,1_","_+BKMIEN_",",2.3,"E"))
; Retrieve diagnosis date from diag cat history
S LSTDXDT=$O(^BKM(90451,BKMIEN,1,BKMREG,10,"B",""),-1)
I LSTDXDT S LINE=LINE_" "_$$FMTE^XLFDT(LSTDXDT\1,"5Z")
D UPD
S LINE=" Register Status: "_$$LOWER^VALM1($G(TEMP(90451.01,1_","_+BKMIEN_",",.5,"E")))
I $G(TEMP(90451.01,1_","_+BKMIEN_",",.75,"I")) S LINE=LINE_" "_$P($$FMTE^XLFDT(TEMP(90451.01,1_","_+BKMIEN_",",.75,"I"),"5Z"),"@")
D UPD
S LINE=" HIV/ AIDS Diagnostic Tag Status: "_$$HIVTAG^BKMVSUP6(DFN)
D UPD
S LINE=" HIV Clinical Classification (A1-C3): "_$G(TEMP(90451.01,1_","_+BKMIEN_",",3,"E"))
I $G(TEMP(90451.01,1_","_+BKMIEN_",",3.5,"I")) S LINE=LINE_" "_$P($$FMTE^XLFDT(TEMP(90451.01,1_","_+BKMIEN_",",3.5,"I"),"5Z"),"@")
D UPD
S LINE=" Diagnosis Comments: "_$$GET1^DIQ(90451.01,BKMREG_","_BKMIEN_",",2.7,"I")
D UPD
S LINE=" Initial HIV Diagnosis: "
S HIVDXDT=$G(TEMP(90451.01,1_","_+BKMIEN_",",5,"I"))
I HIVDXDT]"" S TMPDT=$$FMTE^XLFDT(HIVDXDT,"5Z") S:$P(TMPDT,"/",2)="00" TMPDT=$P(TMPDT,"/",1)_"/"_$P(TMPDT,"/",3) S LINE=LINE_TMPDT
; The default value for this field, if not populated, is yet to be worked out but will be displayed as value,"[**]",!
D UPD
S LINE=" Initial AIDS Diagnosis: "
I $G(TEMP(90451.01,1_","_+BKMIEN_",",5.5,"I")) S TMPDT=$$FMTE^XLFDT(TEMP(90451.01,1_","_+BKMIEN_",",5.5,"I"),"5Z") S:$P(TMPDT,"/",2)="00" TMPDT=$P(TMPDT,"/",1)_"/"_$P(TMPDT,"/",3) S LINE=LINE_TMPDT
; The default value for this field, if not populated, is yet to be worked out but will be displayed as value,"[**]",!
K TEMP
;
OI ; Opportunistic Infections
D UPD,BLANK(1)
S LINE=" Opportunistic infections and AIDS Defining Illnesses"
D UPD
; Modified code to use new structure for ICD9S array from BKMVC6.
N DIC,DIQ,DR,DA,STDT,ICD9S,ICDDSC,PNARR,ICD,NAR,DASH,ENTDT
S DASH="",$P(DASH,"-",79)=""
D GETALL^BKMVSUP6(DFN) ; Returns the Opportunistic infections in local array ICD9S(ACTDATE,INDEX,"ICD9")=ICD
; Only look at opportunistic infections since initial HIV diagnosis date.
; If there is none look at last 6 months.
; *** Removed date check at request of IHS ***
; S STDT=$S(HIVDXDT]"":HIVDXDT,1:$$FMADD^XLFDT(DT,-183)),STDT=9999999-STDT
I $D(ICD9S) D
. S A1="",L=0
. F S A1=$O(ICD9S(A1)) Q:A1="" D
.. S BKMDT=$P($$FMTE^XLFDT(9999999-A1,"5Z"),"@")
.. S K=""
.. F S K=$O(ICD9S(A1,K)) Q:K="" D
... I 'L D
.... I LNCNT>(MAXCT-2) D NEWPG
.... S LINE=" Onset",LINE=$$LINE(LINE,"Entry",15),LINE=$$LINE(LINE,"ICD",27)
.... S LINE=$$LINE(LINE,"ICD",35),LINE=$$LINE(LINE,"Provider",49)
.... S LINE=$$LINE(LINE,"Status of",69) D UPD
.... S LINE=" Date",LINE=$$LINE(LINE," Date",15),LINE=$$LINE(LINE,"Code",27)
.... S LINE=$$LINE(LINE,"Narrative",35),LINE=$$LINE(LINE,"Narrative",49)
.... S LINE=$$LINE(LINE," Problem",69) D UPD
.... ;S LINE=" [Date]",LINE=$$LINE(LINE,"[ICD9]",20)
.... ;S LINE=$$LINE(LINE,"[Description]",28),LINE=$$LINE(LINE,"[Status]",60)
.... ;S LINE=$$LINE(LINE,"[Provider Narrative]",70)
.... ;S LINE=$$LINE(LINE,"[Description]",28),LINE=$$LINE(LINE,"[Provider Narrative]",55)
.... S LINE=DASH D UPD
... K ICD,NAR
... I $$VERSION^XPDUTL("BCSV") S ICDDSC=$$ICDD^BKMUL3("ICD9",K,9999999-A1) ; csv
... I '$$VERSION^XPDUTL("BCSV") S ICDDSC=$$GET1^DIQ(80,K,10,"E")
... D PARSE(ICDDSC,12,"ICD")
... S PNARR=$P($G(ICD9S(A1,K)),U,2) D PARSE(PNARR,18,"NAR")
... S LINE=" "_BKMDT,ENTDT=$P(ICD9S(A1,K),U,3)
... I ENTDT'="" S LINE=$$LINE(LINE,$$FMTE^XLFDT(ENTDT,"5Z"),15)
... I $$VERSION^XPDUTL("BCSV") S LINE=$$LINE(LINE,$$ICD9^BKMUL3(K,9999999-A1,2),27) ; csv
... I '$$VERSION^XPDUTL("BCSV") S LINE=$$LINE(LINE,$$GET1^DIQ(80,K,.01,"E"),27)
... ;S LINE=$$LINE(LINE,BKMDT,5),LINE=$$LINE(LINE,$$ICD9^BKMUL3(K,9999999-A1,2),20) ; csv
... S LINE=$$LINE(LINE,$G(ICD(1)),35),LINE=$$LINE(LINE,$G(NAR(1)),49)
... ;S LINE=$$LINE(LINE,$E($$ICDD^BKMUL3("ICD9",K,9999999-A1),1,25),28) ; csv
... ; S LINE=$$LINE(LINE,BKMDT,5),LINE=$$LINE(LINE,$$GET1^DIQ(80,K,.01,"E"),20)
... ; S LINE=$$LINE(LINE,$E($$GET1^DIQ(80,K,10,"E"),1,25),28)
... S LINE=$$LINE(LINE,$P($G(ICD9S(A1,K)),U),69)
... ;S LINE=$$LINE(LINE,$P($G(ICD9S(A1,K)),U),60),LINE=$$LINE(LINE,$P($G(ICD9S(A1,K)),U,2),70)
... ;S LINE=$$LINE(LINE,$$G(ICD9S(A1,K)),55)
... D UPD
... S L=1
... I LNCNT>MAXCT D NEWPG
... I $O(ICD(1))!$O(NAR(1)) D
.... N IX
.... F IX=2:1 Q:'$D(ICD(IX))&'$D(NAR(IX)) D
..... S LINE=""
..... I $D(ICD(IX)) S LINE=$$LINE(LINE,ICD(IX),35)
..... I $D(NAR(IX)) S LINE=$$LINE(LINE,NAR(IX),49)
..... D UPD
; PRXM/HC/ALA Modified 9/22/2005
D GETS^DIQ(90451.01,"1,"_+BKMIEN_",","4;4.1;4.2;4.3;4.5;4.51;4.52;4.53","EI","STCAT")
D UPD S LINE=" State Notification(s): "
I $G(STCAT("90451.01","1,"_+BKMIEN_",","4.3","E"))'="" D
. S LINE=$$LINE(LINE,"HIV ",23)_$G(STCAT(90451.01,"1,"_+BKMIEN_",","4.3","E"))
. I $G(STCAT(90451.01,"1,"_+BKMIEN_",","4","I")) S LINE=LINE_" "_$$FMTE^XLFDT(STCAT(90451.01,"1,"_+BKMIEN_",","4","I"),"5Z")
. D UPD
I $G(STCAT("90451.01","1,"_+BKMIEN_",","4.53","E"))'="" D
. S LINE=$$LINE(LINE,"AIDS ",23)_$G(STCAT(90451.01,"1,"_+BKMIEN_",","4.53","E"))
. I $G(STCAT(90451.01,"1,"_+BKMIEN_",","4.5","I")) S LINE=LINE_" "_$$FMTE^XLFDT(STCAT(90451.01,"1,"_+BKMIEN_",","4.5","I"),"5Z")
. D UPD
. I LNCNT>MAXCT D NEWPG
I $G(STCAT("90451.01","1,"_+BKMIEN_",","4.3","E"))="",$G(STCAT("90451.01","1,"_+BKMIEN_",","4.53","E"))="" D UPD ;W !
I LNCNT>MAXCT D NEWPG
S LINE=" Partner Notification: "
S BKM=$$GET1^DIQ(90451.01,"1,"_+BKMIEN_",",15,"E") S LINE=LINE_BKM
S BKM=$$FMTE^XLFDT($$GET1^DIQ(90451.01,"1,"_+BKMIEN_",",16,"I"),"5Z") S LINE=LINE_" "_BKM
;S BKM=$$GET1^DIQ(90451.01,"1,"_+BKMIEN_",",15,"E") S LINE=LINE_BKM
D UPD
I LNCNT>MAXCT D NEWPG
;
; Begin LAB RESULTS
; Variable QUIT is initialized in ONEY/ONE and reset based on user's response to press enter to continue
; Variable MAXCT is set by PRINT to IOSL-4
I LNCNT>(MAXCT-2) D NEWPG
D UPD S LINE=" RECENT LABORATORY RESULTS: "
D UPD,BLANK(1) ;,!,!
I LNCNT>MAXCT D NEWPG
D CD4^BKMVSUP1(DFN)
D VIRAL^BKMVSUP1(DFN)
D LIPID^BKMVSUP6(DFN)
D RPR^BKMVSUP1(DFN)
D PAP^BKMVSUP1(DFN)
D CHL^BKMVSUP1(DFN)
D GON^BKMVSUP1(DFN)
D HEP^BKMVSUP4(DFN)
D HEPA^BKMVSUP4(DFN)
D HEPB^BKMVSUP4(DFN)
D HEPC^BKMVSUP4(DFN)
D CMV^BKMVSUP1(DFN)
D TOX^BKMVSUP1(DFN)
D COC^BKMVSUP1(DFN)
D PPD^BKMVSUP1(DFN)
D PHENO^BKMVSUP1(DFN)
D GENO^BKMVSUP1(DFN)
; Immunizations
D IMM^BKMVSUP2(DFN)
; Medications
D DRUGS^BKMVSUP3(DFN)
; Screenings
D SCREENS^BKMVSUP2(DFN)
; Eye exam
D RET^BKMVSUP3(DFN)
; Print Dental exam date
D DEN^BKMVSUP3(DFN)
; Print Mammogram date
D MAM^BKMVSUP3(DFN)
; Print HIV Education
D ED^BKMVSUP5(DFN)
; Print Reminders
D REM^BKMVSUP5(DFN)
; Print Flow Sheet
D FLOW^BKMVSUP5(DFN)
D BLANK(2)
S LINE=" "_$E($$CONF^BKMVSUP6(1),1,78) D UPD ;Write end confidential message
Q
;
BMI(PT,HT,HTD,WT,WTD,AGE) ; Calculate BMI
Q
; PT = patient's DFN
; HT = patient's height
; HTD = date patient's height was recorded
; WT = patient's weight
; WTD = date patient's weight was recorded
; AGE = patient's age (taken from 9000001,1102.98)
;
;N BMI,WDIFF,HDIFF
;I PT=""!(HT="")!(WT="")!(AGE="") Q ""
; Patients younger than 19 must have both measurements on the same day
;I AGE<19,HTD'=WTD Q ""
;S WDIFF=$$FMDIFF^XLFDT(DT,WTD,1)
;S HDIFF=$$FMDIFF^XLFDT(DT,HTD,1)
; Patients older than 50 must have both measurements in the last two years
;I AGE>50,WDIFF>(2*365)!(HDIFF>(2*365)) Q ""
; Patients between 19 and 50 must have both measurements in the last five years
;I AGE<50,AGE>18,WDIFF>(5*365)!(HDIFF>(5*365)) Q ""
;S BMI=$$BMI^APCHS2A3(PT,WT,DT)
;Q $$STRIP^XLFSTR($P(BMI,U,1)," ")
; S WT=WT*.45359,HT=HT*.0254 ;Convert to metric
; Q $J(WT/(HT*HT),0,1)
;
LINE(TEXT,STR,POS) ; Set text to match HMS Supplement formatting
I $L(TEXT)>POS Q TEXT_STR
S $E(TEXT,POS)=STR
Q TEXT
;
UPD ; Update global with line of text; update page and total line count
I LNCNT>MAXCT D NEWPG
S ^TMP("BKMVSUP",$J,PGCNT,LNCNT)=LINE,LINE="",LNCNT=LNCNT+1
Q
;
NEWPG ; Print new page
S PGCNT=PGCNT+1,LNCNT=1
Q
;
BLANK(CNT) ; Add blank line(s) to output global
S CNT=$G(CNT,1)
F I=1:1:CNT S ^TMP("BKMVSUP",$J,PGCNT,LNCNT)="",LNCNT=LNCNT+1
Q
;
DT(FDT) ; Date conversion
N %DT,X,Y
S %DT="TS",X=FDT D ^%DT
Q Y
;
PRIV(BKMDUZ) ; EP - Determine if user has access rights in HMS
; Extrinsic function - returns 1 (ability to access HMS data) or
; 0 (no HMS security access established)
; Input:
; BKMDUZ - DUZ, IEN for File 200
; Output: n/a
;
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,1:1)
Q BKMPRIV
;
PARSE(STR,LEN,TARGET) ; Break up text by length and store in provided TARGET
;
I $G(STR)="" Q
I '$G(LEN) Q
I $G(TARGET)="" Q
N I,PC,STR1,CNT
S CNT=0,STR1=""
F I=1:1:$L(STR," ") S PC=$P(STR," ",I) I PC'="" D
. I STR1="",$L(PC)>LEN S CNT=CNT+1,@TARGET@(CNT)=$E(PC,1,LEN),STR1=$E(PC,LEN+2,999)_" " Q
. I $L(STR1_PC)>LEN S CNT=CNT+1,@TARGET@(CNT)=$$TKO^BQIUL1(STR1," "),STR1=PC_" " Q
. S STR1=STR1_PC_" "
I STR1'="" S CNT=CNT+1,@TARGET@(CNT)=$$TKO^BQIUL1(STR1," ")
Q
;
XIT ; Exit from routine
Q
BKMVSUP ;PRXM/HC/WOM - HIV SUPPLEMENT; [ 1/19/2005 7:16 PM ] ; 10 Jun 2005 12:02 PM
+1 ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
+2 QUIT
+3 ;
EP(DFN) ;EP - Called by Health Summary Supplement
+1 ; Value for APCHSPAT is passed to identify the patient (DFN)
+2 ; IO variables will already have been set
+3 NEW X,BKMIEN,DIR,DIRUT
+4 SET DFN=$GET(DFN)
+5 IF DFN=""
QUIT
+6 KILL ^TMP("BKMSUPP",$JOB),^TMP("BKMVSUP",$JOB)
+7 SET X=$ORDER(^BKM(90451,"B",DFN,""))
+8 ;I X="" S X=$$ATAG^BQITDUTL(DFN,"HIV/AIDS") I 'X S X=""
+9 IF X=""
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+10 ;W !!?5,"HMS Patient Care Summary is not available. This patient does not"
+11 ;W !?5,"have an active HIV diagnostic tag and/or is not in the HMS Register.",!
+12 WRITE !!?5,"HMS Patient Care Summary cannot be generated as selected patient"
+13 WRITE !?5,"is not in the HMS Register.",!
End DoDot:1
QUIT
+14 ;
+15 ; Comment out the security check in the event that IHS reconsiders
+16 ; I '$$PRIV(DUZ) D Q
+17 ; . I $E(IOST)="C" D
+18 ; .. W !!,"Sorry, you are currently not an authorized HMS user."
+19 ; .. W !,"Please see your Security Administrator for access.",! H 2
+20 ;
+21 SET BKMIEN=X_U_DFN
SET ^TMP("BKMSUPP",$JOB,"IENS")=BKMIEN
+22 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
Begin DoDot:1
+23 WRITE !!
+24 SET DIR("A")="HMS PATIENT CARE SUMMARY WILL NOW BE DISPLAYED (^ TO EXIT, RETURN TO CONTINUE)"
+25 SET DIR(0)="E"
DO ^DIR
+26 IF $DATA(DIRUT)
SET APCHSQIT=1
QUIT
End DoDot:1
IF $GET(APCHSQIT)
QUIT
+27 NEW LINE,PGCNT,LNCNT
+28 SET (PGCNT,LNCNT)=1
+29 DO EP2(DFN)
+30 DO PRINT
+31 WRITE @IOF
KILL Y
+32 KILL ^TMP("BKMSUPP",$JOB),^TMP("BKMVSUP",$JOB)
+33 QUIT
+34 ;
EP2(DFN) ; Get data and report for one patient
+1 ; Store lines to print in ^TMP("BKMVSUP",$J)
+2 NEW NOW,X,DA,Y,HLDBKM,AUPNPAT,AUDT,AUDATA,PTNAME,HRECNO,PAGES,BKMDT
+3 SET X=$ORDER(^BKM(90451,"B",DFN,""))
+4 ;I X="" S X=$$ATAG^BQITDUTL(DFN,"HIV/AIDS") I 'X S X=""
+5 IF X=""
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+6 ;W !!?5,"HMS Patient Care Summary is not available. This patient does not"
+7 ;W !?5,"have an active HIV diagnostic tag and/or is not in the HMS Register.",!
+8 WRITE !!?5,"HMS Patient Care Summary cannot be generated as selected patient"
+9 WRITE !?5,"is not in the HMS Register.",!
End DoDot:1
QUIT
+10 SET (DA,Y)=X
SET HLDBKM=X_U_DFN
+11 KILL LOCAL,DIC,ICD9S
+12 DO NOW^%DTC
SET NOW=X
+13 IF +Y'<0
DO GET^BKMVSRP1($PIECE(HLDBKM,U))
DO GETDATA
+14 KILL LOCAL,ICD9S,^TMP("BKMSUPP",$JOB)
+15 QUIT
+16 ;
PRINT ; Print report from ^TMP("BKMVSUP",$J)
+1 NEW PAGE,CNT,XNOW,QUIT
+2 USE IO
+3 SET PAGE=""
SET CNT=""
+4 ; Used to identify if user wants to quit display if run to the screen
SET QUIT=""
+5 DO NOW^%DTC
SET XNOW=$$FMTE^XLFDT(X,"5Z")
+6 FOR
SET PAGE=$ORDER(^TMP("BKMVSUP",$JOB,PAGE))
IF 'PAGE
QUIT
Begin DoDot:1
+7 DO HEADER^BKMVSUP6(PAGE,XNOW)
+8 FOR
SET CNT=$ORDER(^TMP("BKMVSUP",$JOB,PAGE,CNT))
Begin DoDot:2
+9 IF 'CNT
SET QUIT=$$PAUSE^BKMVSUP3()
QUIT
+10 WRITE !,^TMP("BKMVSUP",$JOB,PAGE,CNT)
End DoDot:2
IF 'CNT!QUIT
QUIT
End DoDot:1
IF QUIT
QUIT
+11 IF QUIT
SET APCHSQIT=1
+12 QUIT
+13 ;
GETDATA ; Load data in ^TMP
+1 ;
+2 NEW A,DPTIEN,BKMIEN,CLCL,RDIAG,GETSIENS,BKMREG,LSTDXDT,A1,I,J,K,L,BKMDT,TEMP,MAXCT,BKM,BKMT
+3 NEW BMI,%H,DR,STCAT,STIEN,AGE,GLOBAL,CPRDT,CNT,CDDT,Y,CDTST,TYPE,BKMHAART,HIVDXDT,TMPDT
+4 NEW HPRV,HCSM,DBMI
+5 SET MAXCT=IOSL-7
+6 ;
+7 SET DPTIEN=$PIECE(^TMP("BKMSUPP",$JOB,"IENS"),U,2)
SET BKMIEN=$PIECE(^TMP("BKMSUPP",$JOB,"IENS"),U)
+8 SET GETSIENS=BKMIEN
SET DFN=DPTIEN
+9 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+10 ;
+11 ; Array LOCAL is set up with the following subscripts:
+12 ; LOCAL(2,DPTIEN,.01,"I")=name
+13 ; LOCAL(2,DPTIEN,.01,"E")=name
+14 ; LOCAL(2,DPTIEN,.02,"I")=sex...e.g. F for female
+15 ; LOCAL(2,DPTIEN,.03,"I")=date of birth in internal format
+16 ; LOCAL(9000001,BKMIEN,1102.98)=age
+17 ; LOCAL(9000001,BKMIEN,1118)=community
+18 ; LOCAL(90451,BKMIEN,.02,"E")=name
+19 ; LOCAL(90451,BKMIEN,.02,"I")=DPTIEN
+20 ; LOCAL(90451.01,"1,"_BKMIEN_",",.5,"E")=STATUS
+21 ; LOCAL(90451.01,"1,"_BKMIEN_",",2.3,"E")=DIAGNOSIS CATEGORY
+22 ; LOCAL(90451.01,"1,"_BKMIEN_",",4.1,"E")=STATE HIV CONFIRMATION STATUS
+23 ; LOCAL(90451.01,"1,"_BKMIEN_",",4.2,"E")=STATE HIV CONFIRMATION DATE
+24 ; LOCAL(90451.01,"1,"_BKMIEN_",",4.51,"E")=STATE AIDS ACKNOWLEDGEMENT STATUS
+25 ; LOCAL(90451.01,"1,"_BKMIEN_",",4.52,"E")=STATE AIDS ACKNOWLEDGEMENT DATE
+26 ; LOCAL("HRECNO")=HEALTH RECORD NUMBER
+27 ; LOCAL(90451.01,"1,"_BKMIEN_",",.015,"E")=FACILITY(WHERE FOLLOWS)
+28 ;
+29 SET LINE=" Patient's Name: "_$EXTRACT($GET(LOCAL(2,DPTIEN,.01,"E")),1,30)
+30 SET LINE=$$LINE(LINE,"HRN: ",46)_$EXTRACT($GET(LOCAL("HRECNO")),1,8)
+31 DO UPD
+32 SET LINE=" Sex: "_$GET(LOCAL(2,DPTIEN,.02,"I"))
+33 SET LINE=$$LINE(LINE,"DOB: ",19)
+34 SET Y=LOCAL(2,DPTIEN,.03,"I")
SET LINE=LINE_$$FMTE^XLFDT(Y,"5Z")
+35 SET AGE=$EXTRACT($PIECE($GET(LOCAL(9000001,DPTIEN,1102.98))," "),1,3)
+36 SET LINE=$$LINE(LINE,"Age: ",46)_AGE_$EXTRACT($PIECE($GET(LOCAL(9000001,DPTIEN,1102.98))," ",2),1)
+37 DO UPD
+38 SET RDIAG=$PIECE($$DPCP^BQIULPT(DFN),U,2)
+39 ;S RDIAG=$$GET1^DIQ(9000001,DFN,.14,"E")
+40 SET LINE=" Designated Primary Care Provider: "_RDIAG
+41 DO UPD
+42 KILL TEMP
DO GETS^DIQ(90451.01,1_","_+BKMIEN_",",".02;.5;.75;2;2.5;3;3.5;5;5.5;6;6.5","IE","TEMP")
+43 SET LINE=" HIV Provider: "
+44 SET HPRV=$$HPRV^BQIVFDEF(DFN)
IF HPRV
SET HPRV=$$GET1^DIQ(200,HPRV_",",.01,"E")
+45 SET LINE=LINE_HPRV
+46 DO UPD
+47 SET LINE=" HIV Case Manager: "
+48 SET HCSM=$$HCSM^BQIVFDEF(DFN)
IF HCSM
SET HCSM=$$GET1^DIQ(200,HCSM_",",.01,"E")
+49 SET LINE=LINE_HCSM
+50 DO UPD
+51 SET RDIAG=$$HTWT^BKMVSUP2(DFN)
+52 SET LINE=" Last Height: "_$PIECE(RDIAG,U)_" "_$PIECE(RDIAG,U,2)
+53 NEW POS,LEN
+54 SET POS=30
SET LEN=$LENGTH(LINE)
IF LEN>28
SET POS=LEN+2
+55 SET LINE=$$LINE(LINE," Last Weight: ",POS)_$PIECE(RDIAG,U,3)_" "_$PIECE(RDIAG,U,4)
+56 DO UPD
+57 ; Determine BMI
+58 ;S BMI=$$BMI(DFN,$P(RDIAG,U),$$DT($P(RDIAG,U,2)),$P(RDIAG,U,3),$$DT($P(RDIAG,U,4)),AGE)
+59 SET DBMI=$$PBMI^APCLV(DFN,DT)
+60 SET BMI=$PIECE(DBMI,U,1)
+61 IF BMI'=""
SET BMI=$JUSTIFY(BMI,3,2)
+62 ; if BMI cannot be set display the following
+63 IF BMI=""
SET BMI="BMI cannot be calculated with current data. - "_$PIECE(DBMI,U,8)
+64 SET LINE=" BMI: "_BMI
+65 DO UPD
DO BLANK(1)
+66 SET LINE=" Register Diagnosis: "_$GET(LOCAL(90451.01,1_","_+BKMIEN_",",2.3,"E"))
+67 ; Retrieve diagnosis date from diag cat history
+68 SET LSTDXDT=$ORDER(^BKM(90451,BKMIEN,1,BKMREG,10,"B",""),-1)
+69 IF LSTDXDT
SET LINE=LINE_" "_$$FMTE^XLFDT(LSTDXDT\1,"5Z")
+70 DO UPD
+71 SET LINE=" Register Status: "_$$LOWER^VALM1($GET(TEMP(90451.01,1_","_+BKMIEN_",",.5,"E")))
+72 IF $GET(TEMP(90451.01,1_","_+BKMIEN_",",.75,"I"))
SET LINE=LINE_" "_$PIECE($$FMTE^XLFDT(TEMP(90451.01,1_","_+BKMIEN_",",.75,"I"),"5Z"),"@")
+73 DO UPD
+74 SET LINE=" HIV/ AIDS Diagnostic Tag Status: "_$$HIVTAG^BKMVSUP6(DFN)
+75 DO UPD
+76 SET LINE=" HIV Clinical Classification (A1-C3): "_$GET(TEMP(90451.01,1_","_+BKMIEN_",",3,"E"))
+77 IF $GET(TEMP(90451.01,1_","_+BKMIEN_",",3.5,"I"))
SET LINE=LINE_" "_$PIECE($$FMTE^XLFDT(TEMP(90451.01,1_","_+BKMIEN_",",3.5,"I"),"5Z"),"@")
+78 DO UPD
+79 SET LINE=" Diagnosis Comments: "_$$GET1^DIQ(90451.01,BKMREG_","_BKMIEN_",",2.7,"I")
+80 DO UPD
+81 SET LINE=" Initial HIV Diagnosis: "
+82 SET HIVDXDT=$GET(TEMP(90451.01,1_","_+BKMIEN_",",5,"I"))
+83 IF HIVDXDT]""
SET TMPDT=$$FMTE^XLFDT(HIVDXDT,"5Z")
IF $PIECE(TMPDT,"/",2)="00"
SET TMPDT=$PIECE(TMPDT,"/",1)_"/"_$PIECE(TMPDT,"/",3)
SET LINE=LINE_TMPDT
+84 ; The default value for this field, if not populated, is yet to be worked out but will be displayed as value,"[**]",!
+85 DO UPD
+86 SET LINE=" Initial AIDS Diagnosis: "
+87 IF $GET(TEMP(90451.01,1_","_+BKMIEN_",",5.5,"I"))
SET TMPDT=$$FMTE^XLFDT(TEMP(90451.01,1_","_+BKMIEN_",",5.5,"I"),"5Z")
IF $PIECE(TMPDT,"/",2)="00"
SET TMPDT=$PIECE(TMPDT,"/",1)_"/"_$PIECE(TMPDT,"/",3)
SET LINE=LINE_TMPDT
+88 ; The default value for this field, if not populated, is yet to be worked out but will be displayed as value,"[**]",!
+89 KILL TEMP
+90 ;
OI ; Opportunistic Infections
+1 DO UPD
DO BLANK(1)
+2 SET LINE=" Opportunistic infections and AIDS Defining Illnesses"
+3 DO UPD
+4 ; Modified code to use new structure for ICD9S array from BKMVC6.
+5 NEW DIC,DIQ,DR,DA,STDT,ICD9S,ICDDSC,PNARR,ICD,NAR,DASH,ENTDT
+6 SET DASH=""
SET $PIECE(DASH,"-",79)=""
+7 ; Returns the Opportunistic infections in local array ICD9S(ACTDATE,INDEX,"ICD9")=ICD
DO GETALL^BKMVSUP6(DFN)
+8 ; Only look at opportunistic infections since initial HIV diagnosis date.
+9 ; If there is none look at last 6 months.
+10 ; *** Removed date check at request of IHS ***
+11 ; S STDT=$S(HIVDXDT]"":HIVDXDT,1:$$FMADD^XLFDT(DT,-183)),STDT=9999999-STDT
+12 IF $DATA(ICD9S)
Begin DoDot:1
+13 SET A1=""
SET L=0
+14 FOR
SET A1=$ORDER(ICD9S(A1))
IF A1=""
QUIT
Begin DoDot:2
+15 SET BKMDT=$PIECE($$FMTE^XLFDT(9999999-A1,"5Z"),"@")
+16 SET K=""
+17 FOR
SET K=$ORDER(ICD9S(A1,K))
IF K=""
QUIT
Begin DoDot:3
+18 IF 'L
Begin DoDot:4
+19 IF LNCNT>(MAXCT-2)
DO NEWPG
+20 SET LINE=" Onset"
SET LINE=$$LINE(LINE,"Entry",15)
SET LINE=$$LINE(LINE,"ICD",27)
+21 SET LINE=$$LINE(LINE,"ICD",35)
SET LINE=$$LINE(LINE,"Provider",49)
+22 SET LINE=$$LINE(LINE,"Status of",69)
DO UPD
+23 SET LINE=" Date"
SET LINE=$$LINE(LINE," Date",15)
SET LINE=$$LINE(LINE,"Code",27)
+24 SET LINE=$$LINE(LINE,"Narrative",35)
SET LINE=$$LINE(LINE,"Narrative",49)
+25 SET LINE=$$LINE(LINE," Problem",69)
DO UPD
+26 ;S LINE=" [Date]",LINE=$$LINE(LINE,"[ICD9]",20)
+27 ;S LINE=$$LINE(LINE,"[Description]",28),LINE=$$LINE(LINE,"[Status]",60)
+28 ;S LINE=$$LINE(LINE,"[Provider Narrative]",70)
+29 ;S LINE=$$LINE(LINE,"[Description]",28),LINE=$$LINE(LINE,"[Provider Narrative]",55)
+30 SET LINE=DASH
DO UPD
End DoDot:4
+31 KILL ICD,NAR
+32 ; csv
IF $$VERSION^XPDUTL("BCSV")
SET ICDDSC=$$ICDD^BKMUL3("ICD9",K,9999999-A1)
+33 IF '$$VERSION^XPDUTL("BCSV")
SET ICDDSC=$$GET1^DIQ(80,K,10,"E")
+34 DO PARSE(ICDDSC,12,"ICD")
+35 SET PNARR=$PIECE($GET(ICD9S(A1,K)),U,2)
DO PARSE(PNARR,18,"NAR")
+36 SET LINE=" "_BKMDT
SET ENTDT=$PIECE(ICD9S(A1,K),U,3)
+37 IF ENTDT'=""
SET LINE=$$LINE(LINE,$$FMTE^XLFDT(ENTDT,"5Z"),15)
+38 ; csv
IF $$VERSION^XPDUTL("BCSV")
SET LINE=$$LINE(LINE,$$ICD9^BKMUL3(K,9999999-A1,2),27)
+39 IF '$$VERSION^XPDUTL("BCSV")
SET LINE=$$LINE(LINE,$$GET1^DIQ(80,K,.01,"E"),27)
+40 ;S LINE=$$LINE(LINE,BKMDT,5),LINE=$$LINE(LINE,$$ICD9^BKMUL3(K,9999999-A1,2),20) ; csv
+41 SET LINE=$$LINE(LINE,$GET(ICD(1)),35)
SET LINE=$$LINE(LINE,$GET(NAR(1)),49)
+42 ;S LINE=$$LINE(LINE,$E($$ICDD^BKMUL3("ICD9",K,9999999-A1),1,25),28) ; csv
+43 ; S LINE=$$LINE(LINE,BKMDT,5),LINE=$$LINE(LINE,$$GET1^DIQ(80,K,.01,"E"),20)
+44 ; S LINE=$$LINE(LINE,$E($$GET1^DIQ(80,K,10,"E"),1,25),28)
+45 SET LINE=$$LINE(LINE,$PIECE($GET(ICD9S(A1,K)),U),69)
+46 ;S LINE=$$LINE(LINE,$P($G(ICD9S(A1,K)),U),60),LINE=$$LINE(LINE,$P($G(ICD9S(A1,K)),U,2),70)
+47 ;S LINE=$$LINE(LINE,$$G(ICD9S(A1,K)),55)
+48 DO UPD
+49 SET L=1
+50 IF LNCNT>MAXCT
DO NEWPG
+51 IF $ORDER(ICD(1))!$ORDER(NAR(1))
Begin DoDot:4
+52 NEW IX
+53 FOR IX=2:1
IF '$DATA(ICD(IX))&'$DATA(NAR(IX))
QUIT
Begin DoDot:5
+54 SET LINE=""
+55 IF $DATA(ICD(IX))
SET LINE=$$LINE(LINE,ICD(IX),35)
+56 IF $DATA(NAR(IX))
SET LINE=$$LINE(LINE,NAR(IX),49)
+57 DO UPD
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+58 ; PRXM/HC/ALA Modified 9/22/2005
+59 DO GETS^DIQ(90451.01,"1,"_+BKMIEN_",","4;4.1;4.2;4.3;4.5;4.51;4.52;4.53","EI","STCAT")
+60 DO UPD
SET LINE=" State Notification(s): "
+61 IF $GET(STCAT("90451.01","1,"_+BKMIEN_",","4.3","E"))'=""
Begin DoDot:1
+62 SET LINE=$$LINE(LINE,"HIV ",23)_$GET(STCAT(90451.01,"1,"_+BKMIEN_",","4.3","E"))
+63 IF $GET(STCAT(90451.01,"1,"_+BKMIEN_",","4","I"))
SET LINE=LINE_" "_$$FMTE^XLFDT(STCAT(90451.01,"1,"_+BKMIEN_",","4","I"),"5Z")
+64 DO UPD
End DoDot:1
+65 IF $GET(STCAT("90451.01","1,"_+BKMIEN_",","4.53","E"))'=""
Begin DoDot:1
+66 SET LINE=$$LINE(LINE,"AIDS ",23)_$GET(STCAT(90451.01,"1,"_+BKMIEN_",","4.53","E"))
+67 IF $GET(STCAT(90451.01,"1,"_+BKMIEN_",","4.5","I"))
SET LINE=LINE_" "_$$FMTE^XLFDT(STCAT(90451.01,"1,"_+BKMIEN_",","4.5","I"),"5Z")
+68 DO UPD
+69 IF LNCNT>MAXCT
DO NEWPG
End DoDot:1
+70 ;W !
IF $GET(STCAT("90451.01","1,"_+BKMIEN_",","4.3","E"))=""
IF $GET(STCAT("90451.01","1,"_+BKMIEN_",","4.53","E"))=""
DO UPD
+71 IF LNCNT>MAXCT
DO NEWPG
+72 SET LINE=" Partner Notification: "
+73 SET BKM=$$GET1^DIQ(90451.01,"1,"_+BKMIEN_",",15,"E")
SET LINE=LINE_BKM
+74 SET BKM=$$FMTE^XLFDT($$GET1^DIQ(90451.01,"1,"_+BKMIEN_",",16,"I"),"5Z")
SET LINE=LINE_" "_BKM
+75 ;S BKM=$$GET1^DIQ(90451.01,"1,"_+BKMIEN_",",15,"E") S LINE=LINE_BKM
+76 DO UPD
+77 IF LNCNT>MAXCT
DO NEWPG
+78 ;
+79 ; Begin LAB RESULTS
+80 ; Variable QUIT is initialized in ONEY/ONE and reset based on user's response to press enter to continue
+81 ; Variable MAXCT is set by PRINT to IOSL-4
+82 IF LNCNT>(MAXCT-2)
DO NEWPG
+83 DO UPD
SET LINE=" RECENT LABORATORY RESULTS: "
+84 ;,!,!
DO UPD
DO BLANK(1)
+85 IF LNCNT>MAXCT
DO NEWPG
+86 DO CD4^BKMVSUP1(DFN)
+87 DO VIRAL^BKMVSUP1(DFN)
+88 DO LIPID^BKMVSUP6(DFN)
+89 DO RPR^BKMVSUP1(DFN)
+90 DO PAP^BKMVSUP1(DFN)
+91 DO CHL^BKMVSUP1(DFN)
+92 DO GON^BKMVSUP1(DFN)
+93 DO HEP^BKMVSUP4(DFN)
+94 DO HEPA^BKMVSUP4(DFN)
+95 DO HEPB^BKMVSUP4(DFN)
+96 DO HEPC^BKMVSUP4(DFN)
+97 DO CMV^BKMVSUP1(DFN)
+98 DO TOX^BKMVSUP1(DFN)
+99 DO COC^BKMVSUP1(DFN)
+100 DO PPD^BKMVSUP1(DFN)
+101 DO PHENO^BKMVSUP1(DFN)
+102 DO GENO^BKMVSUP1(DFN)
+103 ; Immunizations
+104 DO IMM^BKMVSUP2(DFN)
+105 ; Medications
+106 DO DRUGS^BKMVSUP3(DFN)
+107 ; Screenings
+108 DO SCREENS^BKMVSUP2(DFN)
+109 ; Eye exam
+110 DO RET^BKMVSUP3(DFN)
+111 ; Print Dental exam date
+112 DO DEN^BKMVSUP3(DFN)
+113 ; Print Mammogram date
+114 DO MAM^BKMVSUP3(DFN)
+115 ; Print HIV Education
+116 DO ED^BKMVSUP5(DFN)
+117 ; Print Reminders
+118 DO REM^BKMVSUP5(DFN)
+119 ; Print Flow Sheet
+120 DO FLOW^BKMVSUP5(DFN)
+121 DO BLANK(2)
+122 ;Write end confidential message
SET LINE=" "_$EXTRACT($$CONF^BKMVSUP6(1),1,78)
DO UPD
+123 QUIT
+124 ;
BMI(PT,HT,HTD,WT,WTD,AGE) ; Calculate BMI
+1 QUIT
+2 ; PT = patient's DFN
+3 ; HT = patient's height
+4 ; HTD = date patient's height was recorded
+5 ; WT = patient's weight
+6 ; WTD = date patient's weight was recorded
+7 ; AGE = patient's age (taken from 9000001,1102.98)
+8 ;
+9 ;N BMI,WDIFF,HDIFF
+10 ;I PT=""!(HT="")!(WT="")!(AGE="") Q ""
+11 ; Patients younger than 19 must have both measurements on the same day
+12 ;I AGE<19,HTD'=WTD Q ""
+13 ;S WDIFF=$$FMDIFF^XLFDT(DT,WTD,1)
+14 ;S HDIFF=$$FMDIFF^XLFDT(DT,HTD,1)
+15 ; Patients older than 50 must have both measurements in the last two years
+16 ;I AGE>50,WDIFF>(2*365)!(HDIFF>(2*365)) Q ""
+17 ; Patients between 19 and 50 must have both measurements in the last five years
+18 ;I AGE<50,AGE>18,WDIFF>(5*365)!(HDIFF>(5*365)) Q ""
+19 ;S BMI=$$BMI^APCHS2A3(PT,WT,DT)
+20 ;Q $$STRIP^XLFSTR($P(BMI,U,1)," ")
+21 ; S WT=WT*.45359,HT=HT*.0254 ;Convert to metric
+22 ; Q $J(WT/(HT*HT),0,1)
+23 ;
LINE(TEXT,STR,POS) ; Set text to match HMS Supplement formatting
+1 IF $LENGTH(TEXT)>POS
QUIT TEXT_STR
+2 SET $EXTRACT(TEXT,POS)=STR
+3 QUIT TEXT
+4 ;
UPD ; Update global with line of text; update page and total line count
+1 IF LNCNT>MAXCT
DO NEWPG
+2 SET ^TMP("BKMVSUP",$JOB,PGCNT,LNCNT)=LINE
SET LINE=""
SET LNCNT=LNCNT+1
+3 QUIT
+4 ;
NEWPG ; Print new page
+1 SET PGCNT=PGCNT+1
SET LNCNT=1
+2 QUIT
+3 ;
BLANK(CNT) ; Add blank line(s) to output global
+1 SET CNT=$GET(CNT,1)
+2 FOR I=1:1:CNT
SET ^TMP("BKMVSUP",$JOB,PGCNT,LNCNT)=""
SET LNCNT=LNCNT+1
+3 QUIT
+4 ;
DT(FDT) ; Date conversion
+1 NEW %DT,X,Y
+2 SET %DT="TS"
SET X=FDT
DO ^%DT
+3 QUIT Y
+4 ;
PRIV(BKMDUZ) ; EP - Determine if user has access rights in HMS
+1 ; Extrinsic function - returns 1 (ability to access HMS data) or
+2 ; 0 (no HMS security access established)
+3 ; Input:
+4 ; BKMDUZ - DUZ, IEN for File 200
+5 ; Output: n/a
+6 ;
+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,1:1)
+14 QUIT BKMPRIV
+15 ;
PARSE(STR,LEN,TARGET) ; Break up text by length and store in provided TARGET
+1 ;
+2 IF $GET(STR)=""
QUIT
+3 IF '$GET(LEN)
QUIT
+4 IF $GET(TARGET)=""
QUIT
+5 NEW I,PC,STR1,CNT
+6 SET CNT=0
SET STR1=""
+7 FOR I=1:1:$LENGTH(STR," ")
SET PC=$PIECE(STR," ",I)
IF PC'=""
Begin DoDot:1
+8 IF STR1=""
IF $LENGTH(PC)>LEN
SET CNT=CNT+1
SET @TARGET@(CNT)=$EXTRACT(PC,1,LEN)
SET STR1=$EXTRACT(PC,LEN+2,999)_" "
QUIT
+9 IF $LENGTH(STR1_PC)>LEN
SET CNT=CNT+1
SET @TARGET@(CNT)=$$TKO^BQIUL1(STR1," ")
SET STR1=PC_" "
QUIT
+10 SET STR1=STR1_PC_" "
End DoDot:1
+11 IF STR1'=""
SET CNT=CNT+1
SET @TARGET@(CNT)=$$TKO^BQIUL1(STR1," ")
+12 QUIT
+13 ;
XIT ; Exit from routine
+1 QUIT
