Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BKMQSSR

BKMQSSR.m

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