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

BQIPTIMM.m

Go to the documentation of this file. 
  1. BQIPTIMM ;PRXM/HC/ALA - PATIENT IMMUNIZATIONS ; 27 Mar 2007  11:00 AM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  ;
  1.  Q
  1.  ;
  1. IMM(DATA,DFN,DRANGE) ; EP -- BQI PATIENT IMMUNIZATIONS
  1.  ;
  1.  ;Description - all the immunizations that a patient has
  1.  ;
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  ;
  1.  NEW UID,II,IEN,VISIT,VSDTM,IMMN,SERIES,LOT,REAC,SITE,VOL,VCDTM,ORPHY,ENPHY
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTIMM",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTIMM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S DRANGE=$$DATE^BQIUL1($G(DRANGE))
  1.  S @DATA@(II)="I00010IMM_IEN^I00010VISIT_IEN^D00030VISIT_DATETIME^T00100IMMUNIZATION^T00006SERIES^T00030REACTION^T00035ORD_PROV^T00035ENC_PROV"_$C(30)
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVIMM("AC",DFN,IEN),-1) Q:IEN=""  D
  1.  . S IMMN=$$GET1^DIQ(9000010.11,IEN_",",.01,"E") I IMMN="" Q
  1.  . S VISIT=$$GET1^DIQ(9000010.11,IEN_",",.03,"I") I VISIT="" Q
  1.  . S VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I") I VSDTM=0 Q
  1.  . I DRANGE'="",(VSDTM\1<DRANGE) Q
  1.  . S SERIES=$$GET1^DIQ(9000010.11,IEN_",",.04,"E")
  1.  . S LOT=$$GET1^DIQ(9000010.11,IEN_",",.05,"E")
  1.  . S REAC=$$GET1^DIQ(9000010.11,IEN_",",.06,"E")
  1.  . S SITE=$$GET1^DIQ(9000010.11,IEN_",",.09,"E")
  1.  . S VOL=$$GET1^DIQ(9000010.11,IEN_",",.11,"E")
  1.  . S VCDTM=$$GET1^DIQ(9000010.11,IEN_",",.12,"I")
  1.  . S ORPHY=$$GET1^DIQ(9000010.11,IEN_",",1202,"E")
  1.  . S ENPHY=$$GET1^DIQ(9000010.11,IEN_",",1204,"E")
  1.  . S II=II+1,@DATA@(II)=IEN_U_VISIT_U_$$FMTE^BQIUL1(VSDTM)_U_IMMN_U_SERIES_U_REAC_U_ORPHY_U_ENPHY_$C(30)
  1.  ;
  1.  ; Check for refusals
  1.  D REF
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. REF ; Check for refusals
  1.  NEW IMM,RVDT,REVDT,RFIEN,IMMUN,REAC,ORPHY,SERIES,ENPHY
  1.  S IMM=""
  1.  F  S IMM=$O(^AUPNPREF("AA",DFN,9999999.14,IMM)) Q:IMM=""  D
  1.  . S RVDT=""
  1.  . F  S RVDT=$O(^AUPNPREF("AA",DFN,9999999.14,IMM,RVDT)) Q:RVDT=""  D
  1.  .. ; Reverse the reverse date
  1.  .. S REVDT=9999999-RVDT
  1.  .. I DRANGE'="",(REVDT\1)<DRANGE Q
  1.  .. S RFIEN=""
  1.  .. F  S RFIEN=$O(^AUPNPREF("AA",DFN,9999999.14,IMM,RVDT,RFIEN)) Q:RFIEN=""  D
  1.  ... S IMMUN=$$GET1^DIQ(9999999.14,IMM_",",.01,"E")
  1.  ... S REAC=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
  1.  ... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
  1.  ... S SERIES="",ENPHY=""
  1.  ... S II=II+1,@DATA@(II)=U_U_$$FMTE^BQIUL1(REVDT)_U_IMMUN_U_SERIES_U_REAC_U_ORPHY_U_ENPHY_$C(30)
  1.  Q
  1.  ;
  1. GLS(DATA,FAKE) ;EP - BQI GET IMMUNIZATIONS GLOSSARY
  1.  NEW UID,II,TRIEN,CAT,TIT,SORT,RMK,REMARK,CT,NXT,GLIEN,IEN,IIEN
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIIMGLS",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTIMM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="T32767REPORT_TEXT"_$C(30)
  1.  S GLIEN=$O(^BQI(90508.2,"B","Immunizations","")) I GLIEN="" S BMXSEC="Problem with Immunizations glossary in file 90508.2" G DONE
  1.  S IEN=0 F  S IEN=$O(^BQI(90508.2,GLIEN,1,IEN)) Q:'IEN  D
  1.  . S II=II+1,@DATA@(II)=$G(^BQI(90508.2,GLIEN,1,IEN,0))
  1.  ;S GLIEN=$O(^BQI(90506.5,"B","Immunizations","")) I GLIEN="" S BMXSEC="Problem with Immunizations source list" G DONE
  1.  ;S IEN=0 F  S IEN=$O(^BQI(90506.5,GLIEN,10,IEN)) Q:'IEN  D
  1.  ;. S IIEN=$P(^BQI(90506.5,GLIEN,10,IEN,0),U,4)
  1.  ;. S II=II+1,@DATA@(II)="    "_$P(^BQI(90506.5,GLIEN,10,IEN,0),U,3)_" ("_$P($G(^AUTTIMM(IIEN,1)),U,14)_")"
  1.  I II>0 S @DATA@(II)=@DATA@(II)_$C(30)
  1.  ;
  1. DONE S II=II+1,@DATA@(II)=$C(31)
  1.  Q