- 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