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

BQITRUT1.m

Go to the documentation of this file. 
  1. BQITRUT1 ;VNGT/HS/ALA-Treatment Prompt Utility Program ; 03 Sep 2008  8:55 AM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  ;
  1. NEX(BQDFN,TMFRAME) ;EP - No Exercise API
  1.  NEW X,MEET,DESC
  1.  S MEET=0,DESC=""
  1.  D
  1.  . ;S X=$$DX^BQITRUTL($$DATE^BQIUL1(TMFRAME),BQDFN,"V65.41")
  1.  . S X=$$TAX^BQITRUT1(BQDFN,TMFRAME,"BQI EXERCISE COUNSELING DXS",9000010.07)
  1.  . I $P(X,U,1)=1 S MEET=0,DESC="Has DX for V65.41-EXERCISE COUNSELING" Q
  1.  . S X=$$FED^BQITREDU($$DATE^BQIUL1(TMFRAME),BQDFN,"-EX")
  1.  . I $P(X,U,1)=1 S MEET=0,DESC="Has Education Topic: "_$$GET1^DIQ(9000010.16,$P(X,U,5)_",",.01,"E")_" "_$$FMTE^BQIUL1($P(X,U,2)) Q
  1.  . ;S X=$$FED^BQITREDU($$DATE^BQIUL1(TMFRAME),BQDFN,"-LA")
  1.  . ;I $P(X,U,1)=1 S MEET=0,DESC="Has Education Topic: "_$$GET1^DIQ(9000010.16,$P(X,U,5)_",",.01,"E")_" "_$$FMTE^BQIUL1($P(X,U,2)) Q
  1.  . S MEET=1,DESC="Has no exercise education topics or diagnosis"
  1.  Q MEET_U_DESC
  1.  ;
  1. NNU(BQDFN,TMFRAME) ;EP - No Nutrition API
  1.  NEW X,MEET,DESC
  1.  S MEET=0,DESC=""
  1.  D
  1.  . ;S X=$$DX^BQITRUTL($$DATE^BQIUL1(TMFRAME),BQDFN,"V65.3")
  1.  . S X=$$TAX^BQITRUT1(BQDFN,TMFRAME,"BGP DIETARY SURVEILLANCE DXS",9000010.07)
  1.  . I $P(X,U,1)=1 S MEET=0,DESC="Has DX for V65.3-DIETARY SURVEIL/COUNSEL" Q
  1.  . ;S X=$$FED^BQITREDU($$DATE^BQIUL1(TMFRAME),BQDFN,"-NU")
  1.  . S X=$$TOP($$DATE^BQIUL1(TMFRAME),BQDFN,"-N","NUTRITION")
  1.  . I $P(X,U,1)=1 S MEET=0,DESC="Has Education topic: "_$$GET1^DIQ(9000010.16,$P(X,U,5)_",",.01,"E")_" "_$$FMTE^BQIUL1($P(X,U,2)) Q
  1.  . S X=$$FED^BQITREDU($$DATE^BQIUL1(TMFRAME),BQDFN,"-MNT")
  1.  . I $P(X,U,1)=1 S MEET=0,DESC="Has Education topic: "_$$GET1^DIQ(9000010.16,$P(X,U,5)_",",.01,"E")_" "_$$FMTE^BQIUL1($P(X,U,2)) Q
  1.  . S MEET=1,DESC="Has no nutrition education topics or diagnosis"
  1.  Q MEET_U_DESC
  1.  ;
  1. TAX(BQDFN,TMFRAME,TAX,FREF) ;EP - Documented value from a taxonomy
  1.  NEW MEET,DESC,EDATE,GREF,TREF,IEN,QFL,TIEN,VISIT,VSDTM
  1.  S MEET=0,DESC=""
  1.  S TMFRAME=$G(TMFRAME,""),TAX=$G(TAX,"")
  1.  I TMFRAME'="" S EDATE=$$DATE^BQIUL1(TMFRAME)
  1.  S GREF=$$ROOT^DILFD(FREF,"",1),TREF=$NA(^TMP("BQITAX",UID))
  1.  ;  Build the taxonomy reference
  1.  K @TREF
  1.  Q:TAX=""
  1.  D BLD^BQITUTL(TAX,TREF)
  1.  S IEN="",QFL=0
  1.  F  S IEN=$O(@GREF@("AC",BQDFN,IEN),-1) Q:IEN=""  D  Q:QFL
  1.  . S TIEN=$$GET1^DIQ(FREF,IEN_",",.01,"I") I TIEN="" Q
  1.  . I '$D(@TREF@(TIEN)) Q
  1.  . S VISIT=$$GET1^DIQ(FREF,IEN_",",.03,"I") I VISIT="" Q
  1.  . I $$GET1^DIQ(9000010,VISIT_",",.11,"I")=1 Q
  1.  . S VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I")\1 I VSDTM=0 Q
  1.  . I $G(TMFRAME)'="",VSDTM<EDATE Q
  1.  . S MEET=1,DESC="Has value from taxonomy "_TAX
  1.  Q MEET_U_DESC
  1.  ;
  1. EKG(BQDFN,TMFRAME) ;EP
  1.  NEW RETURN
  1.  S RETURN=$$TAX^BQITRUT1(BQDFN,TMFRAME,"BQI EKG PROCEDURES",9000010.08)
  1.  I $P(RETURN,U,1)=0 S MEET=1,DESC="Does not have EKG procedure in past year"
  1.  I $P(RETURN,U,1)=1 S MEET=0,DESC=$P(RETURN,U,2)
  1.  Q MEET_U_DESC
  1.  ;
  1. TOP(DATE,BQDFN,CODE,TEXT) ;Build the topic data
  1.  S TREF=$NA(^TMP("BQITOPIC",UID)),RES=0
  1.  S DATE=$G(DATE,""),TEXT=$G(TEXT,"")
  1.  K @TREF
  1.  D EDTP^BQITRUTL(TREF,CODE)
  1.  S IEN=""
  1.  F  S IEN=$O(@TREF@(IEN)) Q:IEN=""  D
  1.  . I TEXT="" Q
  1.  . I @TREF@(IEN)'[TEXT K @TREF@(IEN)
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVPED("AC",BQDFN,IEN)) Q:IEN=""  D
  1.  . S TIEN=$P($G(^AUPNVPED(IEN,0)),U,1) I TIEN="" Q
  1.  . I '$D(@TREF@(TIEN)) Q
  1.  . S VIEN=$P(^AUPNVPED(IEN,0),U,3) I VIEN="" Q
  1.  . S VSDTM=$P($G(^AUPNVSIT(VIEN,0)),U,1)\1 I VSDTM=0 Q
  1.  . I DATE'="",VSDTM<DATE Q
  1.  . S RES=1_U_VSDTM_U_U_VIEN_U_IEN
  1.  K @TREF
  1.  Q RES
  1.  ;
  1.  ;
  1. LBB(START,END,RECENT,BQDFN,TAX,RESULT,OPER,RES2,OPER2,TREF) ;EP
  1.  ; Check for a lab test result
  1.  ;
  1.  ; Input
  1.  ;   TMFRAME - Time frame to search data for
  1.  ;   RECENT  - 1=Only check most recent lab,0=Check all within timeframe
  1.  ;   BQDFN   - Patient internal entry number
  1.  ;   TAX     - Lab taxonomy to search
  1.  ;   RESULT  - Lab result to check for
  1.  ;   OPER    - Operand to use for result check
  1.  ;   RES2    - If range, the other result value
  1.  ;   OPER2   - If range, the other result operand
  1.  ;   TREF    - Multiple same resulting taxonomies built
  1.  ;             into reference (usually global)
  1.  ;
  1.  NEW TEMP,EDATE,BDATE,LIEN,QFL,RES,CT,VALUE,VIEN,VSDTM
  1.  S BDATE=$G(START),EDATE=$G(END)
  1.  S TEMP=$NA(^TMP("BQITEMP",UID)) K @TEMP
  1.  S TAX=$G(TAX,"")
  1.  I TAX'="" D
  1.  . S TREF=$NA(^TMP("BQITAX",UID)),RES2=$G(RES2,""),OPER2=$G(OPER2,""),RECENT=$G(RECENT,0)
  1.  . K @TREF
  1.  . D BLD^BQITUTL(TAX,TREF)
  1.  ;
  1.  S LIEN="",QFL=0,RES=0_U_"No Test",CT=0
  1.  I $G(BDATE)'="" D
  1.  . S TIEN=""
  1.  . F  S TIEN=$O(@TREF@(TIEN)) Q:TIEN=""  D
  1.  .. S EDT=9999999-BDATE,BDT=(9999999-EDATE)-.001
  1.  .. I $P($G(^LAB(60,TIEN,0)),U,4)="MI" D MIC^BQICAUTL(BQDFN,TIEN,EDT,BDT,.MICRO) Q
  1.  .. F  S BDT=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT)  D
  1.  ... S LIEN=""
  1.  ... F  S LIEN=$O(^AUPNVLAB("AA",BQDFN,TIEN,BDT,LIEN)) Q:LIEN=""  D
  1.  .... S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
  1.  .... S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
  1.  .... S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1.  .... ;I $G(TMFRAME)'="",VSDTM<BDATE Q
  1.  .... ; quit if deleted flag
  1.  .... I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1.  .... I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
  1.  .... S @TEMP@(VSDTM,VIEN,LIEN)=VALUE
  1.  ;
  1.  I $G(BDATE)="" D
  1.  . S LIEN=""
  1.  . F  S LIEN=$O(^AUPNVLAB("AC",BQDFN,LIEN),-1) Q:LIEN=""  D
  1.  .. S TIEN=$P($G(^AUPNVLAB(LIEN,0)),U,1) I TIEN="" Q
  1.  .. I '$D(@TREF@(TIEN)) Q
  1.  .. S VALUE=$P(^AUPNVLAB(LIEN,0),U,4) I VALUE="" Q
  1.  .. S VIEN=$P(^AUPNVLAB(LIEN,0),U,3) I VIEN="" Q
  1.  .. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1.  .. ; quit if deleted flag
  1.  .. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1.  .. I $P($G(^AUPNVLAB(LIEN,11)),U,9)="D" Q
  1.  .. S @TEMP@(VSDTM,VIEN,LIEN)=VALUE
  1.  . F  S LIEN=$O(^AUPNVMIC("AC",BQDFN,LIEN),-1) Q:LIEN=""  D
  1.  .. S TIEN=$P($G(^AUPNVMIC(LIEN,0)),U,1) I TIEN="" Q
  1.  .. I '$D(@TREF@(TIEN)) Q
  1.  .. S VALUE=$P(^AUPNVMIC(LIEN,0),U,7) I VALUE="" Q
  1.  .. S VIEN=$P(^AUPNVMIC(LIEN,0),U,3) I VIEN="" Q
  1.  .. S VSDTM=$$GET1^DIQ(9000010,VIEN_",",.01,"I")\1 I VSDTM=0 Q
  1.  .. ; quit if deleted flag
  1.  .. I $P($G(^AUPNVSIT(VIEN,0)),U,11)=1 Q
  1.  .. I $P($G(^AUPNVMIC(LIEN,11)),U,9)="D" Q
  1.  .. S MICRO(VSDTM,VIEN,LIEN)=VALUE
  1.  ;
  1.  S VSDTM=""
  1.  F  S VSDTM=$O(@TEMP@(VSDTM),-1) Q:VSDTM=""  D  Q:QFL
  1.  . S VIEN=$O(@TEMP@(VSDTM,""),-1),LIEN=""
  1.  . F  S LIEN=$O(@TEMP@(VSDTM,VIEN,LIEN),-1) Q:LIEN=""!(QFL)  D
  1.  .. S VALUE=@TEMP@(VSDTM,VIEN,LIEN)
  1.  .. S CT=CT+1 I RECENT,CT=1 S QFL=1,RES=0_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_$P(^AUPNVLAB(LIEN,0),U,1)
  1.  .. ;
  1.  .. I RESULT'?.N,VALUE?.N Q
  1.  .. ; If the operand is a 'contains', check the comment text
  1.  .. I OPER="[" D  Q
  1.  ... NEW LN
  1.  ... S RESULT=$$UP^XLFSTR(RESULT)
  1.  ... S LN=0 F  S LN=$O(^AUPNVLAB(LIEN,21,LN)) Q:'LN  D  Q:QFL
  1.  .... I $$UP^XLFSTR(^AUPNVLAB(LIEN,21,LN,0))[RESULT S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_$P(^AUPNVLAB(LIEN,0),U,1),QFL=1
  1.  .. ;
  1.  .. I RESULT="POS",$E(VALUE,1)'?.N,'$$POSITIVE^BQITRUTL(VALUE) Q
  1.  .. I RESULT="POS",$E(VALUE,1)'?.N,$$POSITIVE^BQITRUTL(VALUE) D  Q
  1.  ... S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_$P(^AUPNVLAB(LIEN,0),U,1),QFL=1
  1.  .. I RESULT="NEG",$E(VALUE,1)'?.N,'$$NEGATIVE^BQITRUTL(VALUE) Q
  1.  .. I RESULT="NEG",$E(VALUE,1)'?.N,$$NEGATIVE^BQITRUTL(VALUE) D
  1.  ... S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_$P(^AUPNVLAB(LIEN,0),U,1),QFL=1
  1.  .. I $E(VALUE,1)'?.N Q
  1.  .. ;I $E(VALUE,$L(VALUE))?.P S VALUE=VALUE_"0"
  1.  .. I $E(VALUE,$L(VALUE),$L(VALUE))?.P S VALUE=$E(VALUE,1,$L(VALUE)-1)
  1.  .. I RES2="" D
  1.  ... I @("VALUE"_OPER_"RESULT") D
  1.  .... S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_$P(^AUPNVLAB(LIEN,0),U,1),QFL=1
  1.  .. I RES2'="" D
  1.  ... I @("VALUE"_OPER_"RESULT"),@("VALUE"_OPER2_"RES2") D
  1.  .... S RES=1_U_$$FMTE^BQIUL1(VSDTM)_U_VALUE_U_VIEN_U_LIEN_U_$P(^AUPNVLAB(LIEN,0),U,1),QFL=1
  1.  K @TEMP
  1.  Q RES
  1.  ;
  1. CLN(TMFRAME,BQDFN,CLINIC) ;EP
  1.  ; Find visits for a clinic code
  1.  ; Input
  1.  ;   TMFRAME - Time frame to search data for
  1.  ;   BQDFN   - Patient internal entry number
  1.  ;   CLINIC  - Clinic code
  1.  NEW ENDT,BCLN,IEN,QFL,RESULT
  1.  S TMFRAME=$G(TMFRAME,""),ENDT=$$DATE^BQIUL1(TMFRAME)
  1.  S BCLN=$$FIND1^DIC(40.7,"","Q",CLINIC,"C","","ERROR")
  1.  S IEN="",QFL=0,RESULT=0
  1.  I $G(TMFRAME)'="" D
  1.  . S EDT=9999999-ENDT,BDT=""
  1.  . F  S BDT=$O(^AUPNVSIT("AA",BQDFN,BDT)) Q:BDT=""!(BDT>EDT)  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^AUPNVSIT("AA",BQDFN,BDT,IEN)) Q:IEN=""  D
  1.  ... I $$GET1^DIQ(9000010,IEN,.11,"I")=1 Q
  1.  ... S VSDTM=$$GET1^DIQ(9000010,IEN,.01,"I")\1 Q:VSDTM=0
  1.  ... I $$GET1^DIQ(9000010,IEN,.08,"I")=BCLN S QFL=1,RESULT=1_U_VSDTM_U_U_IEN_U
  1.  ;
  1.  I $G(TMFRAME)="" D
  1.  . F  S IEN=$O(^AUPNVSIT("AC",BQDFN,IEN),-1) Q:IEN=""  D  Q:QFL
  1.  .. I $$GET1^DIQ(9000010,IEN,.11,"I")=1 Q
  1.  .. S VSDTM=$$GET1^DIQ(9000010,IEN,.01,"I")\1 Q:VSDTM=0
  1.  .. I $$GET1^DIQ(9000010,IEN,.08,"I")=BCLN S QFL=1,RESULT=1_U_VSDTM_U_U_IEN_U
  1.  Q RESULT