BKMQSSR ;PRXM/HC/CJS - STATE SURV. REPORT ; 14 Jun 2005 3:06 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
;
; This report will use the skeleton structure as provided by
; file 90456
; This report is generated for the supplied list of DFNs (PLIST)
; (the blank form option is not supported here)
EN(DATA,PLIST) ;EP - PRIMARY REPORT ENTRY POINT
; values for DATA and PLIST are supplied by the calling routine
;
; Check taxonomies - added per bugzilla #1497
; This will be accomplished through an RPC call to BQITAXX
N GLOB,CNT,DENPOP,BKMX,BQII,LIST,II,DFN
N BKMLOC,BKMVLOC,BKMVLAD,BKMVLAD1,BKMVLST,BKMVLCTY,BKMVLZIP ; FAC variables
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BKMQSSR D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
; Age at diagnosis check will be performed before calling this report
;I $$CKAGE() G XIT
S BQII=0
S PLIST=$G(PLIST,"")
I PLIST="" D
. S LIST="",BN=""
. F S BN=$O(PLIST(BN)) Q:BN="" S LIST=LIST_PLIST(BN)
. K PLIST
. S PLIST=LIST
. K LIST
I PLIST'="" D FAC
F II=1:1 S DFN=$P(PLIST,$C(28),II) Q:DFN="" D GDATA D UPD^BKMQUTL($C(12),,1)
I PLIST="" D
. N LNLEN,LINE,X
. N APCHSPAT,APCHSTYP
. S LNLEN=80
. D HDR,DQUE1 ;***
S BQII=BQII+1,@DATA@(BQII)=$C(30)
G DONE
;
GDATA ; Retrieve patient information
N BKMDDT,BKMVDOB,BKMVDOD,IEN,BKMDIAG,BKMVAGED,BKMLINE
N BKMVSEX,BKMVSDTH,BKMVSTAT,BKMVHRN,BKMVRCE,BKMVETH
N BKMVPHN,BKMVPOB,BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST
N BKMVPZP,BKMVCNTY,BKMVADDL
N BKMPROV,BKMVPPH
N BKMHDR,BKMPAD,BKMHDR1,PAGE,BKMX,BKM1,BKMLINE1,BKMSEC
N BKM0,BKMDT,BKM2,BKMCC,BKMNDT,BKM,BN
N BKMVETO,BKMCKDT,BKMVNDT,BKMVLN,BKMIEN,BKMSIG,BKMQTY,BKMDAY
N BKMVLABS,BKMICD,BKMSICD,BKMHAART,BKMPCP
D AGE
;S BKMVDOB=$$GET1^DIQ(2,DFN,.03,"I")
;S BKMVDOD=$$GET1^DIQ(2,DFN,.351,"I")
;S IEN=$$FIND1^DIC(90451,,"Q",DFN,"B")
;I IEN'="" S BKMDIAG=$$GET1^DIQ(90451.01,"1,"_IEN,2.3,"E")
I 'BQII D HDR
S BKMX=0
D QUE(DFN)
Q
;
AGE ;GET PATIENT DOB AND DIAGNOSIS INFO AND CALCULATE AGE AT DIAGNOSIS
S BKMDDT=""
S BKMVDOB=$$GET1^DIQ(2,DFN,.03,"I")
S BKMVDOD=$$GET1^DIQ(2,DFN,.351,"I")
S IEN=$$FIND1^DIC(90451,,"Q",DFN,"B")
I IEN]"" D
. S BKMDIAG=$$GET1^DIQ(90451.01,"1,"_IEN,2.3,"E")
. S:BKMDIAG'="HIV"&(BKMDIAG'="AIDS") BKMDIAG=""
. S:BKMDIAG="HIV" BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5,"I")
. S:BKMDIAG="AIDS" BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5.5,"I")
; Calculate age at date of diagnosis, if available.
; Otherwise, calculate age at date of death, if available.
; Otherwise, calculate age at date of report.
D
. I BKMVDOB>0,BKMDDT>0 S BKMVAGED=$$FMDIFF^XLFDT(BKMDDT,BKMVDOB)\365.25 Q
. I BKMVDOB>0,BKMVDOD>0 S BKMVAGED=$$FMDIFF^XLFDT(BKMVDOD,BKMVDOB)\365.25 Q
. I BKMVDOB>0 S BKMVAGED=$$FMDIFF^XLFDT(DT,BKMVDOB)\365.25 Q
. S BKMVAGED="UNK"
Q
FAC ;GATHER FACILITY DATA
S BKMLOC=$$GET1^DIQ(9999999.39,1,.01,"I")
S BKMVLOC=$$GET1^DIQ(4,BKMLOC,.01,"E")
S BKMVLAD=$$GET1^DIQ(4,BKMLOC,1.01,"E")
S BKMVLAD1=$$GET1^DIQ(4,BKMLOC,1.02,"E")
S BKMVLST=$$GET1^DIQ(4,BKMLOC,.02,"E")
S BKMVLCTY=$$GET1^DIQ(4,BKMLOC,1.03,"E")
S BKMVLZIP=$$GET1^DIQ(4,BKMLOC,1.04,"E")
Q
PATDEMO ;GET PATIENT DEMOGRAPHICS
S BKMVSEX=$$GET1^DIQ(2,DFN,.02,"E")
S BKMVSDTH=$$GET1^DIQ(9000001,DFN,1115,"E")
S BKMVSTAT="Alive" I BKMVDOD]"" S BKMVSTAT="Dead"
; An inactive record should be reported as 'Unknown' instead of 'Alive'.
I $G(IEN)]"",$$GET1^DIQ(90451.01,"1,"_IEN,.5,"I")="I",BKMVSTAT="Alive" S BKMVSTAT="Unknown"
S BKMVHRN=$$GET1^DIQ(9000001.41,BKMLOC_","_DFN,.02,"E")
S BKMVRCE=$$GET1^DIQ(9000001,DFN,1111,"E") D
. I BKMVRCE="INDIAN/ALASKA NATIVE" S BKMVRCE="AMERICAN INDIAN OR ALASKA NATIVE" Q
. S BKMVRCE=$$GET1^DIQ(2,DFN,.06,"E")
S BKMVETH="",BKM=0
F S BKM=$O(^DPT(DFN,.06,BKM)) Q:'BKM S BKMVETH=$P(^DPT(DFN,.06,BKM,0),U,1)
S:BKMVETH'="" BKMVETH=$$GET1^DIQ(10.2,BKMVETH,.01,"E")
S BKMVPHN=$$GET1^DIQ(2,DFN,.131,"E")
S BKMVPOB=$$GET1^DIQ(2,DFN,.093,"I")
S BKMVADD1=$$GET1^DIQ(2,DFN,.111,"E")
S BKMVADD2=$$GET1^DIQ(2,DFN,.112,"E")
S BKMVADD3=$$GET1^DIQ(2,DFN,.113,"E")
S BKMVCITY=$$GET1^DIQ(2,DFN,.114,"E")
S BKMVPST=$$GET1^DIQ(2,DFN,.115,"E")
S BKMVPZP=$$GET1^DIQ(2,DFN,.116,"E")
S BKMVCNTY=$$GET1^DIQ(2,DFN,.117,"E")
S BKMVADDL=BKMVADD1_"," D
. I BKMVADD2'="" S BKMVADDL=BKMVADDL_BKMVADD2_","
. I BKMVADD3'="" S BKMVADDL=BKMVADDL_BKMVADD3_","
. I BKMVCITY'="" S BKMVADDL=BKMVADDL_BKMVCITY_","
. I BKMVPST'="" S BKMVADDL=BKMVADDL_BKMVPST_" "
. I BKMVPZP'="" S BKMVADDL=BKMVADDL_" "_BKMVPZP
Q
PRACDIAG ;GATHER PROVIDER DATA
S BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6,"I")
I $G(IEN)]"",BKMPROV="" S BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6.5,"I")
S BKMVPPH=$S(BKMPROV]"":$$GET1^DIQ(200,BKMPROV,.132,"E"),1:"")
I BKMPROV]"" S BKMPROV=$$GET1^DIQ(200,BKMPROV,.01,"E")
Q
QUE(DFN) ;QUEUE REPORT FOR PRINT/DISPLAY
DQUE ;ENTRY FROM QUEUE
N LNLEN,LINE,X
N APCHSPAT,APCHSTYP
;
S LNLEN=80 ; 80 Character display - currently hardcoded - could be a parameter
;D FAC,PATDEMO,PRACDIAG
D PATDEMO,PRACDIAG
D EN^BKMQSSR1 ;G:BKMX XIT
D EN^BKMQSSR2 ;G:BKMX XIT
DQUE1 ;
D EN^BKMQSSR3 ;G:BKMX XIT
D EN^BKMQSSR4 ;G:BKMX XIT
D EN^BKMQSSR5 ;G:BKMX XIT
D EN^BKMQSSR6 ;G:BKMX XIT
Q
XIT ;KILL LOCALS AND EXIT
;K BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST,BKMVPZP,BKMVETH
;K BKMPROV,BKMVPPH,BKMDIAG,BKMDT,BKMVDOB,BKMDDT
;K BKM,BKM0,BKM1,BKM2,BKMIEN,BKMHAART,BKMHDR,BKMHDR1,BKMX,BKMCC
;K BKMICD,BKMLINE,BKMLINE1,BKMLOC,BKMNDT,BKMPAD,BKMPCP,BKMCKDT
;K BKMSEC,BKMSICD,BKMVADDL,BKMVAGED,BKMVDOD,BKMVPOB
;K BKMVETO,BKMVHRN,BKMVLABS,BKMVNDT,BKMVPHN,BKMVCNTY
;K BKMVLAD,BKMVLAD1,BKMVLCTY,BKMVLN,BKMVLOC,BKMVLST,BKMVLZIP
;K BKMSIG,BKMQTY,BKMDAY,BKMVRCE,BKMVSDTH,BKMVSEX,BKMVSTAT,PAGE
K POP,X,Y,DIR,DIWF,DIWL,DIWR,DTOUT,DUOUT,GLOBAL,IEN,%DT,%H,TYPE
Q
;
CKAGE() ;Call AGE subroutine and confirm eligibility for report
D AGE
; *** The following will have to be handled differently since look-up will take place before accessing this
I $G(BKMVAGED)<13 D Q 1
. S BMXSEC="Patient age at diagnosis less than 13. Not a reportable case."
Q ""
;
HDR ;
S @DATA@(BQII)="T00120REPORT_TEXT"_$C(30)
Q
DONE ;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
ERR ;
D ^%ZTER
N Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
Q
BKMQSSR ;PRXM/HC/CJS - STATE SURV. REPORT ; 14 Jun 2005 3:06 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 ;
+4 ; This report will use the skeleton structure as provided by
+5 ; file 90456
+6 ; This report is generated for the supplied list of DFNs (PLIST)
+7 ; (the blank form option is not supported here)
EN(DATA,PLIST) ;EP - PRIMARY REPORT ENTRY POINT
+1 ; values for DATA and PLIST are supplied by the calling routine
+2 ;
+3 ; Check taxonomies - added per bugzilla #1497
+4 ; This will be accomplished through an RPC call to BQITAXX
+5 NEW GLOB,CNT,DENPOP,BKMX,BQII,LIST,II,DFN
+6 ; FAC variables
NEW BKMLOC,BKMVLOC,BKMVLAD,BKMVLAD1,BKMVLST,BKMVLCTY,BKMVLZIP
+7 ;
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BKMQSSR D UNWIND^%ZTER"
+9 ; Age at diagnosis check will be performed before calling this report
+10 ;I $$CKAGE() G XIT
+11 SET BQII=0
+12 SET PLIST=$GET(PLIST,"")
+13 IF PLIST=""
Begin DoDot:1
+14 SET LIST=""
SET BN=""
+15 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+16 KILL PLIST
+17 SET PLIST=LIST
+18 KILL LIST
End DoDot:1
+19 IF PLIST'=""
DO FAC
+20 FOR II=1:1
SET DFN=$PIECE(PLIST,$CHAR(28),II)
IF DFN=""
QUIT
DO GDATA
DO UPD^BKMQUTL($CHAR(12),,1)
+21 IF PLIST=""
Begin DoDot:1
+22 NEW LNLEN,LINE,X
+23 NEW APCHSPAT,APCHSTYP
+24 SET LNLEN=80
+25 ;***
DO HDR
DO DQUE1
End DoDot:1
+26 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(30)
+27 GOTO DONE
+28 ;
GDATA ; Retrieve patient information
+1 NEW BKMDDT,BKMVDOB,BKMVDOD,IEN,BKMDIAG,BKMVAGED,BKMLINE
+2 NEW BKMVSEX,BKMVSDTH,BKMVSTAT,BKMVHRN,BKMVRCE,BKMVETH
+3 NEW BKMVPHN,BKMVPOB,BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST
+4 NEW BKMVPZP,BKMVCNTY,BKMVADDL
+5 NEW BKMPROV,BKMVPPH
+6 NEW BKMHDR,BKMPAD,BKMHDR1,PAGE,BKMX,BKM1,BKMLINE1,BKMSEC
+7 NEW BKM0,BKMDT,BKM2,BKMCC,BKMNDT,BKM,BN
+8 NEW BKMVETO,BKMCKDT,BKMVNDT,BKMVLN,BKMIEN,BKMSIG,BKMQTY,BKMDAY
+9 NEW BKMVLABS,BKMICD,BKMSICD,BKMHAART,BKMPCP
+10 DO AGE
+11 ;S BKMVDOB=$$GET1^DIQ(2,DFN,.03,"I")
+12 ;S BKMVDOD=$$GET1^DIQ(2,DFN,.351,"I")
+13 ;S IEN=$$FIND1^DIC(90451,,"Q",DFN,"B")
+14 ;I IEN'="" S BKMDIAG=$$GET1^DIQ(90451.01,"1,"_IEN,2.3,"E")
+15 IF 'BQII
DO HDR
+16 SET BKMX=0
+17 DO QUE(DFN)
+18 QUIT
+19 ;
AGE ;GET PATIENT DOB AND DIAGNOSIS INFO AND CALCULATE AGE AT DIAGNOSIS
+1 SET BKMDDT=""
+2 SET BKMVDOB=$$GET1^DIQ(2,DFN,.03,"I")
+3 SET BKMVDOD=$$GET1^DIQ(2,DFN,.351,"I")
+4 SET IEN=$$FIND1^DIC(90451,,"Q",DFN,"B")
+5 IF IEN]""
Begin DoDot:1
+6 SET BKMDIAG=$$GET1^DIQ(90451.01,"1,"_IEN,2.3,"E")
+7 IF BKMDIAG'="HIV"&(BKMDIAG'="AIDS")
SET BKMDIAG=""
+8 IF BKMDIAG="HIV"
SET BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5,"I")
+9 IF BKMDIAG="AIDS"
SET BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5.5,"I")
End DoDot:1
+10 ; Calculate age at date of diagnosis, if available.
+11 ; Otherwise, calculate age at date of death, if available.
+12 ; Otherwise, calculate age at date of report.
+13 Begin DoDot:1
+14 IF BKMVDOB>0
IF BKMDDT>0
SET BKMVAGED=$$FMDIFF^XLFDT(BKMDDT,BKMVDOB)\365.25
QUIT
+15 IF BKMVDOB>0
IF BKMVDOD>0
SET BKMVAGED=$$FMDIFF^XLFDT(BKMVDOD,BKMVDOB)\365.25
QUIT
+16 IF BKMVDOB>0
SET BKMVAGED=$$FMDIFF^XLFDT(DT,BKMVDOB)\365.25
QUIT
+17 SET BKMVAGED="UNK"
End DoDot:1
+18 QUIT
FAC ;GATHER FACILITY DATA
+1 SET BKMLOC=$$GET1^DIQ(9999999.39,1,.01,"I")
+2 SET BKMVLOC=$$GET1^DIQ(4,BKMLOC,.01,"E")
+3 SET BKMVLAD=$$GET1^DIQ(4,BKMLOC,1.01,"E")
+4 SET BKMVLAD1=$$GET1^DIQ(4,BKMLOC,1.02,"E")
+5 SET BKMVLST=$$GET1^DIQ(4,BKMLOC,.02,"E")
+6 SET BKMVLCTY=$$GET1^DIQ(4,BKMLOC,1.03,"E")
+7 SET BKMVLZIP=$$GET1^DIQ(4,BKMLOC,1.04,"E")
+8 QUIT
PATDEMO ;GET PATIENT DEMOGRAPHICS
+1 SET BKMVSEX=$$GET1^DIQ(2,DFN,.02,"E")
+2 SET BKMVSDTH=$$GET1^DIQ(9000001,DFN,1115,"E")
+3 SET BKMVSTAT="Alive"
IF BKMVDOD]""
SET BKMVSTAT="Dead"
+4 ; An inactive record should be reported as 'Unknown' instead of 'Alive'.
+5 IF $GET(IEN)]""
IF $$GET1^DIQ(90451.01,"1,"_IEN,.5,"I")="I"
IF BKMVSTAT="Alive"
SET BKMVSTAT="Unknown"
+6 SET BKMVHRN=$$GET1^DIQ(9000001.41,BKMLOC_","_DFN,.02,"E")
+7 SET BKMVRCE=$$GET1^DIQ(9000001,DFN,1111,"E")
Begin DoDot:1
+8 IF BKMVRCE="INDIAN/ALASKA NATIVE"
SET BKMVRCE="AMERICAN INDIAN OR ALASKA NATIVE"
QUIT
+9 SET BKMVRCE=$$GET1^DIQ(2,DFN,.06,"E")
End DoDot:1
+10 SET BKMVETH=""
SET BKM=0
+11 FOR
SET BKM=$ORDER(^DPT(DFN,.06,BKM))
IF 'BKM
QUIT
SET BKMVETH=$PIECE(^DPT(DFN,.06,BKM,0),U,1)
+12 IF BKMVETH'=""
SET BKMVETH=$$GET1^DIQ(10.2,BKMVETH,.01,"E")
+13 SET BKMVPHN=$$GET1^DIQ(2,DFN,.131,"E")
+14 SET BKMVPOB=$$GET1^DIQ(2,DFN,.093,"I")
+15 SET BKMVADD1=$$GET1^DIQ(2,DFN,.111,"E")
+16 SET BKMVADD2=$$GET1^DIQ(2,DFN,.112,"E")
+17 SET BKMVADD3=$$GET1^DIQ(2,DFN,.113,"E")
+18 SET BKMVCITY=$$GET1^DIQ(2,DFN,.114,"E")
+19 SET BKMVPST=$$GET1^DIQ(2,DFN,.115,"E")
+20 SET BKMVPZP=$$GET1^DIQ(2,DFN,.116,"E")
+21 SET BKMVCNTY=$$GET1^DIQ(2,DFN,.117,"E")
+22 SET BKMVADDL=BKMVADD1_","
Begin DoDot:1
+23 IF BKMVADD2'=""
SET BKMVADDL=BKMVADDL_BKMVADD2_","
+24 IF BKMVADD3'=""
SET BKMVADDL=BKMVADDL_BKMVADD3_","
+25 IF BKMVCITY'=""
SET BKMVADDL=BKMVADDL_BKMVCITY_","
+26 IF BKMVPST'=""
SET BKMVADDL=BKMVADDL_BKMVPST_" "
+27 IF BKMVPZP'=""
SET BKMVADDL=BKMVADDL_" "_BKMVPZP
End DoDot:1
+28 QUIT
PRACDIAG ;GATHER PROVIDER DATA
+1 SET BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6,"I")
+2 IF $GET(IEN)]""
IF BKMPROV=""
SET BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6.5,"I")
+3 SET BKMVPPH=$SELECT(BKMPROV]"":$$GET1^DIQ(200,BKMPROV,.132,"E"),1:"")
+4 IF BKMPROV]""
SET BKMPROV=$$GET1^DIQ(200,BKMPROV,.01,"E")
+5 QUIT
QUE(DFN) ;QUEUE REPORT FOR PRINT/DISPLAY
DQUE ;ENTRY FROM QUEUE
+1 NEW LNLEN,LINE,X
+2 NEW APCHSPAT,APCHSTYP
+3 ;
+4 ; 80 Character display - currently hardcoded - could be a parameter
SET LNLEN=80
+5 ;D FAC,PATDEMO,PRACDIAG
+6 DO PATDEMO
DO PRACDIAG
+7 ;G:BKMX XIT
DO EN^BKMQSSR1
+8 ;G:BKMX XIT
DO EN^BKMQSSR2
DQUE1 ;
+1 ;G:BKMX XIT
DO EN^BKMQSSR3
+2 ;G:BKMX XIT
DO EN^BKMQSSR4
+3 ;G:BKMX XIT
DO EN^BKMQSSR5
+4 ;G:BKMX XIT
DO EN^BKMQSSR6
+5 QUIT
XIT ;KILL LOCALS AND EXIT
+1 ;K BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST,BKMVPZP,BKMVETH
+2 ;K BKMPROV,BKMVPPH,BKMDIAG,BKMDT,BKMVDOB,BKMDDT
+3 ;K BKM,BKM0,BKM1,BKM2,BKMIEN,BKMHAART,BKMHDR,BKMHDR1,BKMX,BKMCC
+4 ;K BKMICD,BKMLINE,BKMLINE1,BKMLOC,BKMNDT,BKMPAD,BKMPCP,BKMCKDT
+5 ;K BKMSEC,BKMSICD,BKMVADDL,BKMVAGED,BKMVDOD,BKMVPOB
+6 ;K BKMVETO,BKMVHRN,BKMVLABS,BKMVNDT,BKMVPHN,BKMVCNTY
+7 ;K BKMVLAD,BKMVLAD1,BKMVLCTY,BKMVLN,BKMVLOC,BKMVLST,BKMVLZIP
+8 ;K BKMSIG,BKMQTY,BKMDAY,BKMVRCE,BKMVSDTH,BKMVSEX,BKMVSTAT,PAGE
+9 KILL POP,X,Y,DIR,DIWF,DIWL,DIWR,DTOUT,DUOUT,GLOBAL,IEN,%DT,%H,TYPE
+10 QUIT
+11 ;
CKAGE() ;Call AGE subroutine and confirm eligibility for report
+1 DO AGE
+2 ; *** The following will have to be handled differently since look-up will take place before accessing this
+3 IF $GET(BKMVAGED)<13
Begin DoDot:1
+4 SET BMXSEC="Patient age at diagnosis less than 13. Not a reportable case."
End DoDot:1
QUIT 1
+5 QUIT ""
+6 ;
HDR ;
+1 SET @DATA@(BQII)="T00120REPORT_TEXT"_$CHAR(30)
+2 QUIT
DONE ;
+1 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 QUIT
