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

BKMQQCR.m

Go to the documentation of this file. 
  1. BKMQQCR ;VNGT/HS/ALA - BKMV Quality of Care Report
  1.  ;;2.1;HIV MANAGEMENT SYSTEM;**1**;FEB 7, 2011;Build 30
  1.  Q
  1.  ; Check taxonomies - added per bugzilla #1497
  1.  ;D FLTRMSG^BKMIMRP1 ; will be replaced by RPC call to BQITAXX
  1.  ;
  1. RUN(DATA,BKMRPOP,EDATE,OWNR,PLIEN,BKMTAG,DFN,GUI) ; EP - Run Quality of Care Report
  1.  ;
  1.  ; Input:
  1.  ;    DFN - Either set to a single Patient Internal ID or
  1.  ;          in an array in the following format:
  1.  ;                 DFN(IX)=DFN_$C(28)
  1.  ;    GUI   - Running from GUI is 0, running from RPMS is 1       
  1.  ;    EDATE - Ending date for report
  1.  ;    OWNR  - Owner Internal Entry Number if running report by panel
  1.  ;    PLIEN - Panel Internal Entry Number if running report by panel
  1.  ;    BKMRPOP - Report Population:
  1.  ;            - R = Active on HMS Register
  1.  ;            - D = Active HIV/AIDS Diagnostic Tag
  1.  ;            - P = By selected patients
  1.  ;    BKMTAG  - If BKMRPOP is by Diagnostic Tag, identifies the status:
  1.  ;            - Proposed
  1.  ;            - Accepted
  1.  ;            - Proposed or Accepted
  1.  ;
  1.  N BQII,GLOB,HMSIEN,LIST,II,PT,CNT,DENPOP,NDA
  1.  ;
  1.  S BQII=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BKMQQCR D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  NEW BN,PLNM,LIST,UID,PER1,PERSIX,AMH,BDT,BEGDATE,BKMCCPT,BKMCD4,BKMDFN,BKMIEN,BKMPATN
  1.  NEW BKMREG,BKMVCPT,BKMVIR,CCPT,CD4,COLDTM,CPT,CPTTAXX,CPTTAXX1,CPTTAXX2,DATE,EDT,ENDATE
  1.  NEW GLOBAL3,HEND,HP1B,HP1E,HP2B,HP2E,HP3B,HP3E,HP61B,HP61E,HP62B,HP62E,HREV,HSDTM,ICDTAX1,IEN
  1.  NEW NUMB,P1B,P1E,P2B,P2E,P3B,P3E,P61B,P61E,P62B,P62E,PDATA,PRCTAX,PTOTAL,QFL,REG,REGIEN,RESULT
  1.  NEW REVPER,SITETAX,STAT,TAX,TIEN,TOTPTS,TREF,TXN,TYP,VCPT,VDATA,VSDTM,VIRAL,VISTOT,VSTDT,Y
  1.  NEW VISIT,RGST,TAGST
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S GLOB=$NA(^TMP("BKMQQCRA",UID))
  1.  K @GLOB
  1.  S HMSIEN=$O(^BQI(90506.2,"B","HIV/AIDS",""))
  1.  I HMSIEN="" S BMXSEC="HMS Register missing from file definition." Q
  1.  S EDATE=$$DATE^BQIUL1($G(EDATE))
  1.  S REVPER=$$FMADD^XLFDT(EDATE,-365),PER1=$$FMADD^XLFDT(EDATE,-121)
  1.  S PERSIX=$$FMADD^XLFDT(EDATE,-183)
  1.  I EDATE'[".24" S EDATE=EDATE_".24" ; Report should include info through midnight on the end date.
  1.  S DFN=$G(DFN,""),OWNR=$G(OWNR),PLIEN=$G(PLIEN),PLNM="",GUI=$G(GUI,0)
  1.  ;
  1.  I OWNR="",PLIEN="",GUI D
  1.  . I BKMRPOP="P" Q
  1.  . I BKMRPOP="D" S RIEN="" D
  1.  .. F  S RIEN=$O(^BQIREG("B",3,RIEN)) Q:RIEN=""  D
  1.  ... S TAGST=$P(^BQIREG(RIEN,0),U,3),PT=$P(^BQIREG(RIEN,0),U,2)
  1.  ... I BKMTAG="B",TAGST="A"!(TAGST="P") S @GLOB@("HIVCHK",PT)="" Q
  1.  ... I TAGST=BKMTAG S @GLOB@("HIVCHK",PT)=""
  1.  . I BKMRPOP="R" D
  1.  .. S RIEN=0
  1.  .. F  S RIEN=$O(^BKM(90451,RIEN)) Q:'RIEN  D
  1.  ... S RGST=$P($G(^BKM(90451,RIEN,1,1,0)),U,7),PT=$P(^BKM(90451,RIEN,0),U,1)
  1.  ... I RGST="A" S @GLOB@("HIVCHK",PT)=""
  1.  ;
  1.  I OWNR'="",PLIEN'="" D
  1.  . N IENS,DA
  1.  . S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
  1.  . S PLNM=$$GET1^DIQ(90505.01,IENS,.01,"I")
  1.  . I BKMRPOP="P" Q
  1.  . S PT=0
  1.  . F  S PT=$O(^BQICARE(OWNR,1,PLIEN,40,PT)) Q:'PT  S @GLOB@("HIVCHK",PT)=""
  1.  ;
  1.  I BKMRPOP="P" D
  1.  . I GUI D  Q
  1.  .. S PT="" F  S PT=$O(DFN(PT)) Q:PT=""  S @GLOB@("HIVCHK",PT)=""
  1.  . S LIST=DFN
  1.  . I DFN="" D
  1.  .. S LIST="",BN=""
  1.  .. F  S BN=$O(DFN(BN)) Q:BN=""  S LIST=LIST_DFN(BN)
  1.  .. K DFN
  1.  . F II=1:1 S PT=$P(LIST,$C(28),II) Q:PT=""  S @GLOB@("HIVCHK",PT)=""
  1.  ;
  1.  S DENPOP=$S(BKMRPOP="R":"Active HMS Register Patients",BKMRPOP="P":"User Selected",1:"HIV/AIDS Diagnostic Tag: "_$S(BKMTAG="A":"Accepted",BKMTAG="P":"Proposed",1:"Proposed and Accepted"))
  1.  D ACTWRK^BKMQQCRU
  1.  I '$D(@GLOB@("HIVCHK")) S BMXSEC="RPC Call Failed: This report cannot be run. None of the patients selected for this report meet the criteria."
  1.  G XIT:$G(BMXSEC)'=""
  1.  ;
  1.  S BKMDFN=0
  1.  F CNT=0:1 S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) I 'BKMDFN Q
  1.  S @GLOB@("HIVTOT1")=CNT
  1.  ; compile totals by Gender and Age
  1.  D GENDER,AGE
  1.  NEW DA,DLAYGO,DIC,X,LOGN,BKMUPD
  1.  I $G(^BKM(90450,1,60,0))="" S ^BKM(90450,1,60,0)="^90450.11D^^"
  1.  S DA(1)=1,DLAYGO=90450.11,DIC="^BKM(90450,"_DA(1)_",60,",DIC(0)="L"
  1.  S X=$$NOW^XLFDT() K DO,DD D FILE^DICN S LOGN=+Y
  1.  ; run CD4, Viral load, rapid plasma reagin algorithms
  1.  S BKMUPD(90450.11,LOGN_",1,",.02)=$$NOW^XLFDT()
  1.  D CD4CHK^BKMQQCR1
  1.  S BKMUPD(90450.11,LOGN_",1,",.03)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.04)=$$NOW^XLFDT()
  1.  D VRLLD^BKMQQCR1
  1.  S BKMUPD(90450.11,LOGN_",1,",.05)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.06)=$$NOW^XLFDT()
  1.  D RPR^BKMQQCR1
  1.  S BKMUPD(90450.11,LOGN_",1,",.07)=$$NOW^XLFDT()
  1.  ; run chlamydia, gonorrhea, tuberculosis, and pneumo algorithms
  1.  S BKMUPD(90450.11,LOGN_",1,",.08)=$$NOW^XLFDT()
  1.  D CHLAM^BKMQQCR2
  1.  S BKMUPD(90450.11,LOGN_",1,",.09)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1)=$$NOW^XLFDT()
  1.  D GON^BKMQQCR2
  1.  S BKMUPD(90450.11,LOGN_",1,",.11)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.12)=$$NOW^XLFDT()
  1.  D TBT21^BKMQQCR2
  1.  S BKMUPD(90450.11,LOGN_",1,",.13)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.14)=$$NOW^XLFDT()
  1.  D PNEUMO^BKMQQCR2
  1.  S BKMUPD(90450.11,LOGN_",1,",.15)=$$NOW^XLFDT()
  1.  ; run tetanus, eye, dental, and pap algorithms
  1.  S BKMUPD(90450.11,LOGN_",1,",.16)=$$NOW^XLFDT()
  1.  D TETSTAT^BKMQQCR3
  1.  S BKMUPD(90450.11,LOGN_",1,",.17)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.18)=$$NOW^XLFDT()
  1.  D EYEEXAM^BKMQQCR3
  1.  S BKMUPD(90450.11,LOGN_",1,",.19)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.2)=$$NOW^XLFDT()
  1.  D DENTEXAM^BKMQQCR3
  1.  S BKMUPD(90450.11,LOGN_",1,",.21)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.22)=$$NOW^XLFDT()
  1.  D PAP^BKMQQCR3
  1.  S BKMUPD(90450.11,LOGN_",1,",.23)=$$NOW^XLFDT()
  1.  ; run ARV and MAC algorithms
  1.  S BKMUPD(90450.11,LOGN_",1,",.24)=$$NOW^XLFDT()
  1.  D ARVM03^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.25)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.26)=$$NOW^XLFDT()
  1.  D ARVM02^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.27)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.28)=$$NOW^XLFDT()
  1.  D ARVM05^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.29)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.101)=$$NOW^XLFDT()
  1.  D ARVM09^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.102)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.103)=$$NOW^XLFDT()
  1.  D ARVM10^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.104)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.105)=$$NOW^XLFDT()
  1.  D ARVM11^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.106)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.107)=$$NOW^XLFDT()
  1.  D ARVM12^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.108)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.109)=$$NOW^XLFDT()
  1.  D ARVM13^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.1011)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1012)=$$NOW^XLFDT()
  1.  D PCP^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.1013)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1014)=$$NOW^XLFDT()
  1.  D MAC^BKMQQCR4
  1.  S BKMUPD(90450.11,LOGN_",1,",.1015)=$$NOW^XLFDT()
  1.  ; run tobacco, substance abuse algorithms
  1.  S BKMUPD(90450.11,LOGN_",1,",.1016)=$$NOW^XLFDT()
  1.  D TOBACCO^BKMQQCR5
  1.  S BKMUPD(90450.11,LOGN_",1,",.1017)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1018)=$$NOW^XLFDT()
  1.  D SUBS01^BKMQQCR5
  1.  S BKMUPD(90450.11,LOGN_",1,",.1019)=$$NOW^XLFDT()
  1.  ; run Lipids,HEP C Screen and CRC
  1.  S BKMUPD(90450.11,LOGN_",1,",.1021)=$$NOW^XLFDT()
  1.  D LIPIDS^BKMQQCR2
  1.  S BKMUPD(90450.11,LOGN_",1,",.1022)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1023)=$$NOW^XLFDT()
  1.  D HEPC^BKMQQCR1
  1.  S BKMUPD(90450.11,LOGN_",1,",.1024)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1025)=$$NOW^XLFDT()
  1.  D CRC^BKMQQCR1
  1.  S BKMUPD(90450.11,LOGN_",1,",.1026)=$$NOW^XLFDT()
  1.  ;
  1.  ; New updates for HIVQual
  1.  S BKMUPD(90450.11,LOGN_",1,",.1027)=$$NOW^XLFDT()
  1.  D ^BKMQQCRB
  1.  S BKMUPD(90450.11,LOGN_",1,",.1028)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1029)=$$NOW^XLFDT()
  1.  D ^BKMQQCRC
  1.  S BKMUPD(90450.11,LOGN_",1,",.1031)=$$NOW^XLFDT()
  1.  S BKMUPD(90450.11,LOGN_",1,",.1032)=$$NOW^XLFDT()
  1.  D ^BKMQQCRD
  1.  S BKMUPD(90450.11,LOGN_",1,",.1033)=$$NOW^XLFDT()
  1.  ;K ^ARLIS1 M ^ARLIS1=^TMP("BKMQQCRA",UID)
  1. EN2 ; do mathematical calculations
  1.  D CD4CALC^BKMQQCR6,VRLLDC^BKMQQCR6,RPRCALC^BKMQQCR6
  1.  D CHLAMC^BKMQQCR7,GONCALC^BKMQQCR7,TBCALC^BKMQQCR7
  1.  D PNEUMOC^BKMQQCR8,TETCALC^BKMQQCR8,EYECALC^BKMQQCR8,DENTCALC^BKMQQCR8,PAPCALC^BKMQQCR8
  1.  D ARVCALC^BKMQQCR9,PCP^BKMQQCR9,MAC^BKMQQCR9,TOBCALC^BKMQQCR9,SUBCALC^BKMQQCR9
  1.  D LIPCALC^BKMQQCR8,HEPCCALC^BKMQQCR8,CRCCALC^BKMQQCR8
  1.  D VISCALC^BKMQQCR9,LABCALC^BKMQQCR9,MHCHK^BKMQQCR9,EDCHK^BKMQQCR9
  1.  D APHCALC^BKMQQCR9
  1.  ;
  1. EN3 ; print the report
  1.  D PRINT^BKMQQCRA
  1.  I 'GUI D CLEAN,XIT
  1.  D FILE^DIE("","BKMUPD","ERROR")
  1.  Q
  1.  ;
  1. GENDER ; gender totals compilation
  1.  N DFN,TOTM,TOTF,TOTU,SEX
  1.  S (DFN,TOTM,TOTF,TOTU)=0
  1.  F  S DFN=$O(@GLOB@("HIVCHK",DFN)) Q:'DFN  D
  1.  .S SEX=$$GET1^DIQ(2,DFN_",",".02","I")
  1.  .I SEX="F" S TOTF=TOTF+1 Q
  1.  .I SEX="M" S TOTM=TOTM+1 Q
  1.  .S TOTU=TOTU+1
  1.  S @GLOB@("FEMALE")=TOTF
  1.  S @GLOB@("MALE")=TOTM
  1.  S @GLOB@("UNSPEC")=TOTU
  1.  Q
  1.  ;
  1. AGE ; age totals compilation
  1.  N DFN,AGE,CNT1,CNT2,CNT3,CNT4
  1.  S DFN=0,(CNT1,CNT2,CNT3,CNT4)=0
  1.  F  S DFN=$O(@GLOB@("HIVCHK",DFN)) Q:'DFN  D
  1.  . S AGE=$$AGE^BKMIMRP1(DFN)
  1.  . ; AGE could return days, weeks or months for patients under 3 years
  1.  . I AGE'?1.N S CNT1=CNT1+1 Q
  1.  . ; AGE<15 is a single category
  1.  . I AGE<15 S CNT1=CNT1+1 Q
  1.  . I AGE'>44 S CNT2=CNT2+1 Q
  1.  . I AGE'>64 S CNT3=CNT3+1 Q
  1.  . ; AGE>64
  1.  . S CNT4=CNT4+1
  1.  S @GLOB@("AGE1")=CNT1
  1.  S @GLOB@("AGE2")=CNT2
  1.  S @GLOB@("AGE3")=CNT3
  1.  S @GLOB@("AGE4")=CNT4
  1.  Q
  1.  ;
  1. CLEAN ;clean up variables
  1.  K @GLOB
  1.  Q
  1.  ;
  1. XIT ;
  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