BKMVSSR ;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
EN ;PRIMARY REPORT ENTRY POINT
; Check taxonomies - added per bugzilla #1497
NEW DFLAG
S DFLAG=1 D EN^BKMVC1
N DFN
S BKMX=0
S TYPE=$$TYPE()
I $D(DTOUT)!$D(DUOUT) G XIT
I TYPE="B" D QUE("") G XIT
D RLK^BKMPLKP("") G:$G(DFN)="" XIT
I $$CKAGE() G XIT
D QUE(DFN)
G XIT
;
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
;DFN is set to "" if a blank form is desired
K %ZIS,IOP,IOC,ZTIO S %ZIS="MQ" D ^%ZIS G:POP XIT
I $D(IO("Q")) D G XIT
.S ZTRTN="DQUE^BKMVSSR",ZTDESC="HMS STATE SURVEILLANCE REPORT"
.S ZTSAVE("BKM*")="",ZTSAVE("DFN")="",ZTSAVE("IEN")=""
.K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED" H 2
DQUE ;ENTRY FROM QUEUE
U IO
I $G(DFN)="" G DQUE1 ; Skip DFN lookups if generating blank form.
D FAC,PATDEMO,PRACDIAG
D EN^BKMVSSR1 G:BKMX XIT
D EN^BKMVSSR2 G:BKMX XIT
DQUE1 ;
D EN^BKMVSSR3 G:BKMX XIT
D EN^BKMVSSR4 G:BKMX XIT
D EN^BKMVSSR5 G:BKMX XIT
D EN^BKMVSSR6 G:BKMX XIT
I IOST["C-" D
.I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.W !!?1,"**End of report**"
.S BKMX=$$PAUSE^BKMIXX3
Q
XIT ;KILL LOCALS AND EXIT
D ^%ZISC
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
;
EN1 ;EP - Secondary entry point from within REP action of Review/Edit Patient HMS Record Data option
S BKMX=0
S TYPE=$$TYPE()
I $D(DTOUT)!$D(DUOUT) G XIT
I TYPE="B" D QUE("") G XIT
I $$CKAGE() G XIT
D QUE(DFN)
G XIT
TYPE() ;Type of report requested
K DIR
S DIR(0)="S^B:BLANK;P:PATIENT"
S DIR("A")=" Type of form"
S DIR("?",1)=" 'B' to print a form with fields empty (fill-in-the-blank)"
S DIR("?",2)=" 'P' to print a form with fields filled in for a selected patient"
S DIR("?")=" "
D ^DIR
Q $G(Y)
CKAGE() ;Call AGE subroutine and confirm eligibility for report
D AGE
I $G(BKMVAGED)<13 D I BKMX Q 1
. W !!,"Patient age at diagnosis less than 13. Not a reportable case."
. K DIR
. S DIR(0)="YA"
. S DIR("A")="Would you like to print a copy anyway (Y/N)? ",DIR("B")="N"
. D ^DIR
. I $D(DTOUT)!$D(DUOUT)!(Y=0) S BKMX=1
Q ""
BKMVSSR ;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
EN ;PRIMARY REPORT ENTRY POINT
+1 ; Check taxonomies - added per bugzilla #1497
+2 NEW DFLAG
+3 SET DFLAG=1
DO EN^BKMVC1
+4 NEW DFN
+5 SET BKMX=0
+6 SET TYPE=$$TYPE()
+7 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO XIT
+8 IF TYPE="B"
DO QUE("")
GOTO XIT
+9 DO RLK^BKMPLKP("")
IF $GET(DFN)=""
GOTO XIT
+10 IF $$CKAGE()
GOTO XIT
+11 DO QUE(DFN)
+12 GOTO XIT
+13 ;
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&(BKMDDT>0)
SET BKMVAGED=$$FMDIFF^XLFDT(BKMDDT,BKMVDOB)\365.25
QUIT
+15 IF BKMVDOB>0&(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
+1 ;DFN is set to "" if a blank form is desired
+2 KILL %ZIS,IOP,IOC,ZTIO
SET %ZIS="MQ"
DO ^%ZIS
IF POP
GOTO XIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTRTN="DQUE^BKMVSSR"
SET ZTDESC="HMS STATE SURVEILLANCE REPORT"
+5 SET ZTSAVE("BKM*")=""
SET ZTSAVE("DFN")=""
SET ZTSAVE("IEN")=""
+6 KILL IO("Q")
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"REQUEST QUEUED"
HANG 2
End DoDot:1
GOTO XIT
DQUE ;ENTRY FROM QUEUE
+1 USE IO
+2 ; Skip DFN lookups if generating blank form.
IF $GET(DFN)=""
GOTO DQUE1
+3 DO FAC
DO PATDEMO
DO PRACDIAG
+4 DO EN^BKMVSSR1
IF BKMX
GOTO XIT
+5 DO EN^BKMVSSR2
IF BKMX
GOTO XIT
DQUE1 ;
+1 DO EN^BKMVSSR3
IF BKMX
GOTO XIT
+2 DO EN^BKMVSSR4
IF BKMX
GOTO XIT
+3 DO EN^BKMVSSR5
IF BKMX
GOTO XIT
+4 DO EN^BKMVSSR6
IF BKMX
GOTO XIT
+5 IF IOST["C-"
Begin DoDot:1
+6 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+7 WRITE !!?1,"**End of report**"
+8 SET BKMX=$$PAUSE^BKMIXX3
End DoDot:1
+9 QUIT
XIT ;KILL LOCALS AND EXIT
+1 DO ^%ZISC
+2 KILL BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST,BKMVPZP,BKMVETH
+3 KILL BKMPROV,BKMVPPH,BKMDIAG,BKMDT,BKMVDOB,BKMDDT
+4 KILL BKM,BKM0,BKM1,BKM2,BKMIEN,BKMHAART,BKMHDR,BKMHDR1,BKMX,BKMCC
+5 KILL BKMICD,BKMLINE,BKMLINE1,BKMLOC,BKMNDT,BKMPAD,BKMPCP,BKMCKDT
+6 KILL BKMSEC,BKMSICD,BKMVADDL,BKMVAGED,BKMVDOD,BKMVPOB
+7 KILL BKMVETO,BKMVHRN,BKMVLABS,BKMVNDT,BKMVPHN,BKMVCNTY
+8 KILL BKMVLAD,BKMVLAD1,BKMVLCTY,BKMVLN,BKMVLOC,BKMVLST,BKMVLZIP
+9 KILL BKMSIG,BKMQTY,BKMDAY,BKMVRCE,BKMVSDTH,BKMVSEX,BKMVSTAT,PAGE
+10 KILL POP,X,Y,DIR,DIWF,DIWL,DIWR,DTOUT,DUOUT,GLOBAL,IEN,%DT,%H,TYPE
+11 QUIT
+12 ;
EN1 ;EP - Secondary entry point from within REP action of Review/Edit Patient HMS Record Data option
+1 SET BKMX=0
+2 SET TYPE=$$TYPE()
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO XIT
+4 IF TYPE="B"
DO QUE("")
GOTO XIT
+5 IF $$CKAGE()
GOTO XIT
+6 DO QUE(DFN)
+7 GOTO XIT
TYPE() ;Type of report requested
+1 KILL DIR
+2 SET DIR(0)="S^B:BLANK;P:PATIENT"
+3 SET DIR("A")=" Type of form"
+4 SET DIR("?",1)=" 'B' to print a form with fields empty (fill-in-the-blank)"
+5 SET DIR("?",2)=" 'P' to print a form with fields filled in for a selected patient"
+6 SET DIR("?")=" "
+7 DO ^DIR
+8 QUIT $GET(Y)
CKAGE() ;Call AGE subroutine and confirm eligibility for report
+1 DO AGE
+2 IF $GET(BKMVAGED)<13
Begin DoDot:1
+3 WRITE !!,"Patient age at diagnosis less than 13. Not a reportable case."
+4 KILL DIR
+5 SET DIR(0)="YA"
+6 SET DIR("A")="Would you like to print a copy anyway (Y/N)? "
SET DIR("B")="N"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)
SET BKMX=1
End DoDot:1
IF BKMX
QUIT 1
+9 QUIT ""
