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

BQICMUTL.m

Go to the documentation of this file. 
  1. BQICMUTL ;VNGT/HS/ALA-Care Mgmt Utility ; 25 Jul 2011  7:25 AM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1.  ;
  1. ITM(TMFRAME,BQDFN,FREF,RREF,TIEN,TAX,TREF) ;EP - Find the value
  1.  ; Find visits for a request item
  1.  ; Input
  1.  ;   TMFRAME - Time frame to search data for
  1.  ;   BQDFN   - Patient internal entry number
  1.  ;   FREF    - File to search in
  1.  ;   RREF    - Search file table file
  1.  ;   TIEN    - Item to search on
  1.  ;   TAX     - Taxonomy
  1.  ;   TREF    - Reference array
  1.  ;
  1.  NEW GREF,ENDT,IEN,QFL,RESULT,VISIT,VSDTM,RES,DTM,ITIEN,EDT,BDT,VFL
  1.  NEW SRCTYP
  1.  S TMFRAME=$G(TMFRAME,"")
  1.  I $G(TAX)'="" D
  1.  . S TREF=$NA(^TMP($J,"BQITAX")) K @TREF
  1.  . I $G(RREF)=60 D BLD^BQITUTL(TAX,TREF,"L") Q
  1.  . D BLD^BQITUTL(TAX,TREF)
  1.  I $G(TAX)="" D
  1.  . I $G(TIEN)="" Q
  1.  . S TREF="BQITAX" K @TREF
  1.  . S @TREF@(TIEN)=""
  1.  S GREF=$$ROOT^DILFD(FREF,"",1)
  1.  S VFL=$O(^BQI(90508.6,"B",FREF,""))
  1.  I VFL'="" S SRCTYP=$P(^BQI(90508.6,VFL,0),U,3)
  1.  S ENDT=$$DATE^BQIUL1(TMFRAME)
  1.  S IEN="",QFL=0,RESULT=0
  1.  I $G(TMFRAME)'="" D
  1.  . S EDT=9999999-ENDT,BDT=""
  1.  . I SRCTYP'=2 D  Q
  1.  .. F  S BDT=$O(@GREF@("AA",BQDFN,BDT)) Q:BDT=""!(BDT>EDT)  D  Q:QFL
  1.  ... S IEN=""
  1.  ... F  S IEN=$O(@GREF@("AA",BQDFN,BDT,IEN)) Q:IEN=""  D  Q:QFL
  1.  .... S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
  1.  .... S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
  1.  .... I $G(TIEN)'="",ITIEN'=TIEN Q
  1.  .... I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
  1.  .... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
  1.  .... ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  .... I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
  1.  .... ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
  1.  .... S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
  1.  .... S RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES,QFL=1
  1.  . ;
  1.  . F  S BDT=$O(@GREF@("AA",PTDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT)  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(@GREF@("AA",PTDFN,TIEN,BDT,IEN)) Q:IEN=""  D
  1.  ... S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
  1.  ... S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
  1.  ... I $G(TIEN)'="",ITIEN'=TIEN Q
  1.  ... I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
  1.  ... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
  1.  ... ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  ... I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
  1.  ... ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
  1.  ... S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
  1.  ... S RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES,QFL=1
  1.  . ; check for refusal
  1.  . I $O(^AUPNPREF("AA",BQDFN,RREF,""))'="" D
  1.  .. I $D(TREF) S TIEN="" F  S TIEN=$O(@TREF@(TIEN)) Q:TIEN=""  D
  1.  ... S EDT=9999999-ENDT,BDT=""
  1.  ... F  S BDT=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT)) Q:BDT=""!(BDT>EDT)  D
  1.  .... S IEN="" F  S IEN=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN)) Q:IEN=""  D
  1.  ..... S DTM=$P(^AUPNPREF(IEN,0),U,3)
  1.  ..... I $P(RESULT,U,2)'="",DTM<$P(RESULT,U,2) Q
  1.  ..... S RESULT=1_U_DTM_U_U_U_U_U_"refusal"
  1.  ;
  1.  I $G(TMFRAME)="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(@GREF@("AC",BQDFN,IEN),-1) Q:IEN=""  D  Q:QFL
  1.  .. S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
  1.  .. I $G(TIEN)'="",ITIEN'=TIEN Q
  1.  .. I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
  1.  .. S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
  1.  .. S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
  1.  .. ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  .. I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
  1.  .. ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
  1.  .. S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
  1.  .. S RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES,QFL=1
  1.  . ; check for refusal
  1.  . I $O(^AUPNPREF("AA",BQDFN,RREF,""))'="" D
  1.  .. I $D(TREF) S TIEN="" F  S TIEN=$O(@TREF@(TIEN)) Q:TIEN=""  D
  1.  ... ;S EDT=(9999999-DT)+.001,BDT=""
  1.  ... S BDT="",STOP=0
  1.  ... F  S BDT=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT)) Q:BDT=""  D  Q:STOP
  1.  .... S IEN="" F  S IEN=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN)) Q:IEN=""  D  Q:STOP
  1.  ..... S DTM=$P(^AUPNPREF(IEN,0),U,3)
  1.  ..... I $P(RESULT,U,2)'="",DTM<$P(RESULT,U,2) Q
  1.  ..... S RESULT=1_U_DTM_U_U_U_U_U_"refusal",STOP=1
  1.  Q RESULT
  1.  ;
  1. FTAG(TGN,COLN,BQDFN) ; EP - Find the last entry for a value in Tag
  1.  ; Input Parameters
  1.  ;   TGN   - Tag IEN
  1.  ;   COLN  - Column IEN
  1.  ;   BQDFN - Patient IEN
  1.  ;
  1.  NEW DA,IENS,FRN,FREF,RREF,ITM,NAM,TAX
  1.  S DA(1)=TGN,DA=COLN,IENS=$$IENS^DILF(.DA)
  1.  S FRN=$$GET1^DIQ(90506.26,IENS,.02,"I")
  1.  S FREF=$$PTR^BQIUL2(90506.26,.02,FRN,.02)
  1.  S RREF=$$PTR^BQIUL2(90506.26,.02,FRN,.08)
  1.  S ITM=$$GET1^DIQ(90506.26,IENS,.04,"E")
  1.  ;S DIS=$$GET1^DIQ(90506.26,IENS,.05,"I")
  1.  S NAM=$$GET1^DIQ(90506.26,IENS,.03,"E")
  1.  S TAX=$$GET1^DIQ(90506.26,IENS,.07,"E")
  1.  Q $$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,"")
  1.  ;
  1. FND(CRN,COLN,BQDFN) ;EP - Find the last entry for a value in Source
  1.  ; Input Parameters
  1.  ;   CRN   - Care Mgmt Source IEN
  1.  ;   COLN  - Column IEN
  1.  ;   BQDFN - Patient IEN
  1.  ;
  1.  NEW DA,IENS,FRN,FREF,RREF,ITM,NAM,TAX,EXEC,NONT,APCHSDFN,APCHSPAT
  1.  S (APCHSDFN,APCHSPAT)=BQDFN
  1.  S DA(1)=CRN,DA=COLN,IENS=$$IENS^DILF(.DA)
  1.  S FRN=$$GET1^DIQ(90506.51,IENS,.02,"I")
  1.  S FREF=$$PTR^BQIUL2(90506.51,.02,FRN,.02)
  1.  S RREF=$$PTR^BQIUL2(90506.51,.02,FRN,.08)
  1.  S ITM=$$GET1^DIQ(90506.51,IENS,.04,"E")
  1.  ;S DIS=$$GET1^DIQ(90506.51,IENS,.05,"I")
  1.  S NAM=$$GET1^DIQ(90506.51,IENS,.03,"E")
  1.  S TAX=$$GET1^DIQ(90506.51,IENS,.07,"E")
  1.  S EXEC=$$GET1^DIQ(90506.51,IENS,1,"E")
  1.  S NONT=$$GET1^DIQ(90506.51,IENS,2,"E")
  1.  I EXEC'="" X EXEC
  1.  I EXEC'="",EXEC["VAL" Q VAL
  1.  I EXEC'="",EXEC["RESULT" Q RESULT
  1.  I NONT'="" X NONT
  1.  Q $$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,.TREF)
  1.  ;
  1. SKN ;EP - Skin Test
  1.  S TIEN=$O(^AUTTSK("B","PPD","")) I TIEN="" Q
  1.  S BTREF(TIEN)="PPD",TREF=$NA(BTREF)
  1.  Q
  1.  ;
  1. TB ;EP - Quantiferon lab
  1.  NEW TAX
  1.  S TREF=$NA(BTREF) K @TREF
  1.  S TAX="BQI TB QUANTIFERON LOINC" D BLD^BQITUTL(TAX,.TREF)
  1.  S TAX="BQI TB QUANTIFERON TEST" D BLD^BQITUTL(TAX,.TREF,"L")
  1.  Q
  1.  ;
  1. SER(TAX,RESULT) ;EP - Find a series
  1.  NEW TREF,TIEN
  1.  S TREF=$NA(^TMP($J,"BQITAX")) K @TREF
  1.  D BLD^BQITUTL(TAX,TREF)
  1.  S GREF=$$ROOT^DILFD(FREF,"",1),RREF=FREF
  1.  S IEN="",QFL=0,CT=0,RESULT=CT
  1.  F  S IEN=$O(@GREF@("AC",BQDFN,IEN),-1) Q:'IEN  D
  1.  . S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
  1.  . I $G(TIEN)'="",ITIEN'=TIEN Q
  1.  . I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
  1.  . S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
  1.  . S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
  1.  . ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
  1.  . I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
  1.  . ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
  1.  . S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
  1.  . S CT=CT+1,RESULT=CT
  1.  . S RESULT(CT)=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES
  1.  ; check for refusal
  1.  I $O(^AUPNPREF("AA",BQDFN,RREF,""))'="" D
  1.  . I $D(TREF) S TIEN="" F  S TIEN=$O(@TREF@(TIEN)) Q:TIEN=""  D
  1.  .. S BDT="",STOP=0
  1.  .. F  S BDT=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT)) Q:BDT=""  D
  1.  ... S IEN="" F  S IEN=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN)) Q:IEN=""  D
  1.  .... S DTM=$P(^AUPNPREF(IEN,0),U,3)
  1.  .... I $P(RESULT,U,2)'="",DTM<$P(RESULT,U,2) Q
  1.  .... S CT=CT+1,RESULT=CT
  1.  .... S RESULT(CT)=1_U_DTM_U_U_U_U_U_"refusal"
  1.  I RESULT="" Q
  1.  NEW NRES,BQDTFRM,NCT
  1.  S NRES=""
  1.  S BQDTFRM=$$GET1^DIQ(90506.51,IENS,.08,"I") S:BQDTFRM="" BQDTFRM="S"
  1.  S NCT=""
  1.  F  S NCT=$O(RESULT(NCT),-1) Q:NCT=""  D
  1.  . S NRES=NRES_$S(BQDTFRM="S":$$FMTE^BQIUL1($P(RESULT(NCT),U,2)),1:$$FMTMDY^BQIUL1($P(RESULT(NCT),U,2)))_$C(13)_$C(10)
  1.  . I $P(RESULT(NCT),U,8)="refusal" S NRES=NRES_"(refusal)"_$C(13)_$C(10)
  1.  K RESULT S RESULT=NRES
  1.  Q
  1.  ;
  1. EX(TYPE,RIEN,FIELD,RESULT) ;EP
  1.  NEW MDATA
  1.  I TYPE="PR" D
  1.  . S RESULT=""
  1.  . I FIELD=.01 D  Q
  1.  .. S DN=$$GET1^DIQ(9000011,RIEN_",",FIELD,"I")
  1.  .. I $$VERSION^XPDUTL("AICD")>3.51 S RESULT=1_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]" Q
  1.  .. S RESULT=1_U_$P(^ICD9(DN,0),U,3)_" ["_$P(^ICD9(DN,0),U,1)_"]"
  1.  . I FIELD="ONSET" D  Q
  1.  .. S MDATA=$$PROB^BQIUL1(RIEN) I MDATA="" S RESULT=0
  1.  .. S RESULT=1_U_MDATA
  1.  . I DIS="D" S RESULT=1_U_$$GET1^DIQ(9000011,RIEN_",",FIELD,"I") Q
  1.  . S RESULT=1_U_$$GET1^DIQ(9000011,RIEN_",",FIELD,"E")
  1.  . I RESULT="" S RESULT=0
  1.  I TYPE="AL" D
  1.  . NEW ARIEN
  1.  . S RESULT=""
  1.  . I FIELD=4 S RESULT=1_U_$$GET1^DIQ(120.8,RIEN_",",FIELD,"I") Q
  1.  . I FIELD=14.5 S ARIEN=$O(^GMR(120.85,"C",RIEN,"")) I ARIEN'="" S RESULT=1_U_$$GET1^DIQ(120.85,ARIEN_",",FIELD,"E") Q
  1.  . S RESULT=1_U_$$GET1^DIQ(120.8,RIEN_",",FIELD,"E")
  1.  . I RESULT="" S RESULT=0
  1.  I TYPE="ME" D  Q
  1.  . NEW FILE
  1.  . S FILE=9000010.14,RESULT=""
  1.  . I FIELD="DATE" D
  1.  .. S RES=$$VISD(FILE,RIEN)
  1.  .. I RES'="" S RESULT=1_U_(RES\1)
  1.  . I FIELD?.N!(FIELD?1".".N) D  Q
  1.  .. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
  1.  . S RXN=$$GET1^DIQ(9000010.14,RIEN_",",1102,"E") I RXN="" Q
  1.  . S RXIEN=$O(^PSRX("B",RXN,"")) I RXIEN="" Q
  1.  . I FIELD="STAT" S RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",100,"E")
  1.  . I FIELD="NREF" S RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",9,"E")
  1.  . I FIELD="LDDT" S RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",101,"I")
  1.  . I RESULT="" S RESULT=0
  1.  I TYPE="CP" D  Q
  1.  . NEW FILE
  1.  . S FILE=9000010.18,RESULT=""
  1.  . I FIELD?.N!(FIELD?1".".N) D  Q
  1.  .. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
  1.  . I FIELD="DATE" D
  1.  .. S RES=$$VISD(FILE,RIEN)
  1.  .. I RES'="" S RESULT=1_U_(RES\1)
  1.  . I FIELD="CPT" D
  1.  .. S DN=$P($G(^AUPNVCPT(RIEN,0)),U,1) I DN="" Q
  1.  .. S RESULT=1_U_$P(^ICPT(DN,0),U,1)_" - "_$P(^ICPT(DN,0),U,2)
  1.  . I RESULT="" S RESULT=0
  1.  I TYPE="ER" D  Q
  1.  . NEW FILE
  1.  . S FILE=9009080,RESULT=""
  1.  . I FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N) D  Q
  1.  .. I DFN=RIEN,FIELD'=.05 Q
  1.  .. I DFN=RIEN,FIELD=.05 S RESULT=1_U_$$GET1^DIQ(9009081,RIEN_",",3,"E") Q
  1.  .. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
  1.  . I FIELD="ADATE" D
  1.  .. I DFN=RIEN S RESULT=1_U_$P($G(^AMERADM(RIEN,0)),U,2)\1 Q
  1.  .. S RESULT=1_U_$P($G(^AMERVSIT(RIEN,0)),U,1)
  1.  . I FIELD="DDATE" D
  1.  .. I DFN=RIEN Q
  1.  .. S RESULT=1_U_$P($G(^AMERVSIT(RIEN,6)),U,2)
  1.  . I FIELD="MODE" D
  1.  .. I DFN=RIEN S RESULT=1_U_$$GET1^DIQ(9009081,RIEN_",",6,"E") Q
  1.  .. NEW MODE
  1.  .. S MODE=$$GET1^DIQ(FILE,RIEN_",",.25,"E")
  1.  .. I MODE="" S MODE=$$GET1^DIQ(FILE,RIEN_",",17.3,"E")
  1.  .. I MODE'="" S RESULT=1_U_MODE
  1.  . I RESULT="" S RESULT=0
  1.  I TYPE="LA" D  Q
  1.  . NEW FILE,TEXT,LN,RES
  1.  . S FILE=9000010.09,RESULT=""
  1.  . I FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N) D  Q
  1.  .. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
  1.  . I FIELD="COM" D  Q
  1.  .. S TEXT="",LN=0
  1.  .. F  S LN=$O(^AUPNVLAB(RIEN,21,LN)) Q:'LN  D
  1.  ... S TEXT=TEXT_^AUPNVLAB(RIEN,21,LN,0)_$C(10)_$C(13)
  1.  .. S RESULT=1_U_$$TKO^BQIUL1(TEXT,$C(10)_$C(13))
  1.  . I FIELD="DATE" D
  1.  .. ;S VISIT=$P($G(^AUPNVLAB(RIEN,0)),U,3) I VISIT="" Q
  1.  .. S RES=$$VISD(FILE,RIEN)
  1.  .. I RES'="" S RESULT=1_U_(RES\1)
  1.  . I RESULT="" S RESULT=0
  1.  I TYPE="ED" D  Q
  1.  . NEW FILE,RES
  1.  . S FILE=9000010.16,RESULT=""
  1.  . I FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N) D  Q
  1.  .. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
  1.  . I FIELD="DATE" D
  1.  .. S RES=$$VISD(FILE,RIEN)
  1.  .. I RES'="" S RESULT=1_U_(RES\1)
  1.  . I RESULT="" S RESULT=0
  1.  Q
  1.  ;
  1. VISD(FILE,RIEN) ; EP - Get visit date
  1.  NEW VFILE
  1.  S VFILE=$$ROOT^DILFD(FILE,"",1)
  1.  S VISIT=$P($G(@VFILE@(RIEN,0)),U,3) I VISIT="" Q ""
  1.  Q $P($G(^AUPNVSIT(VISIT,0)),U,1)
  1.  ;
  1. ORD ;EP - Display Order
  1.  NEW BQSRC
  1.  S BQSRC=$$GET1^DIQ(90506.1,D0_",",3.01,"I")
  1.  S BQSRC=$$PTR^BQIUL2(90506.1,3.01,BQSRC,.02)
  1.  W "Previous Order:  ",$O(^BQI(90506.1,"AD",BQSRC,""),-1)
  1.  Q