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

BQITUTL.m

Go to the documentation of this file. 
  1. BQITUTL ;PRXM/HC/ALA-Diagnoses Category Utility Program ; 02 Mar 2006  1:21 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  Q
  1.  ;
  1. BLD(TAX,REF,BQTTYP) ;PEP - Build a taxonomy
  1.  NEW BQTXN
  1.  ;Input
  1.  ;  TAX - Taxonomy name
  1.  ;  REF - reference where list will reside
  1.  I '$$PATCH^XPDUTL("ATX*5.1*11") D BLDTAX^BQITUIX(TAX,REF) Q
  1.  S BQTTYP=$G(BQTTYP,"")
  1.  I BQTTYP="" D
  1.  . S BQQN=$O(^BQI(90508,1,10,"B",TAX,""))
  1.  . I BQQN'="" S BQQY=$P(^BQI(90508,1,10,BQQN,0),U,3)
  1.  . S BQTTYP=$S($G(BQQY)=5:"L",1:"")
  1.  I BQTTYP="L" S BQTXN=$O(^ATXLAB("B",TAX,""))
  1.  E  S BQTXN=$O(^ATXAX("B",TAX,0))
  1.  I BQTXN="" Q
  1.  D BLDTAX^ATXAPI(TAX,REF,BQTXN,BQTTYP)
  1.  K BQTTYP,BQQY
  1.  Q
  1.  ;
  1. BLDSV(FILEREF,VAL,TARGET) ;PEP - Add a single value to a taxonomy
  1.  ;Description
  1.  ;  Use this if no taxonomy was given but an individual code
  1.  ;Input
  1.  ;  FILEREF - File where the code resides
  1.  ;  VAL - Value
  1.  ;  TARGET - reference where entry is to be placed
  1.  ;
  1.  ; The LOINC x-ref in LAB does not use the check digit (piece 2).
  1.  I FILEREF=95.3 S FILE="^LAB(60)",INDEX="AF",VAL=$P(VAL,"-")
  1.  I FILEREF=80 S FILE="^ICD9",INDEX="BA"
  1.  I FILEREF=80.1 S FILE="^ICD0",INDEX="BA"
  1.  I FILEREF=81 S FILE="^ICPT",INDEX="BA"
  1.  S END=VAL
  1.  ;
  1.  ; Backup one entry so loop can find all the entries in the range.
  1.  S VAL=$O(@FILE@(INDEX,VAL),-1)
  1.  F  S VAL=$O(@FILE@(INDEX,VAL)) Q:VAL=""  Q:$$CHECK(VAL,END)  D
  1.  .S IEN=""
  1.  .F  S IEN=$O(@FILE@(INDEX,VAL,IEN)) Q:IEN=""  D
  1.  ..S NAME=$P($G(@FILE@(IEN,0)),U,1)
  1.  ..S @TARGET@(IEN)=NAME
  1.  ;
  1.  K FILEREF,FILE,INDEX,VAL,END,NAME,IEN,TARGET
  1.  Q
  1.  ;
  1. SNOM(SUB,REF) ;PEP - Build a SNOMED subset
  1.  NEW BQIOK,TTREF
  1.  S TTREF=$NA(^TMP("BQISNOM",$J)) K @TTREF
  1.  S BQIOK=$$SUBLST^BSTSAPI(TTREF,SUB_"^36^1")
  1.  S BQN="" F  S BQN=$O(@TTREF@(BQN)) Q:BQN=""  S CID=$P(@TTREF@(BQN),U,1),@REF@(CID)=$P(@TTREF@(BQN),U,3)
  1.  K @TTREF
  1.  Q
  1.  ;
  1. CHECK(V,E) ;EP
  1.  N Z
  1.  I V=E Q 0
  1.  S Z(V)=""
  1.  S Z(E)=""
  1.  I $O(Z(""))=E Q 1
  1.  Q 0
  1.  ;
  1. ARY(DEF,REF) ;EP - Build an array from a definition
  1.  ;Input
  1.  ;  DEF - Definition name
  1.  ;  REF - array name
  1.  ;
  1.  NEW IEN,BN,BDXN,DIC,X,Y,DATA
  1.  S DIC(0)="NZ",X=DEF,DIC="^BQI(90506.2,"
  1.  D ^DIC
  1.  S BDXN=+Y I BDXN<1 Q
  1.  ;
  1.  S BN=0
  1.  F  S BN=$O(^BQI(90506.2,BDXN,5,"B",BN)) Q:'BN  D
  1.  . S IEN=0
  1.  . F  S IEN=$O(^BQI(90506.2,BDXN,5,"B",BN,IEN)) Q:'IEN  D
  1.  .. S DATA=^BQI(90506.2,BDXN,5,IEN,0)
  1.  .. ; If the taxonomy check only flag is set, do not include
  1.  .. I $P(DATA,U,11)=1 Q
  1.  .. ; Exclude the SEARCH ORDER field and only take pieces 2-10
  1.  .. S @REF@(BN)=$P(DATA,U,2,10)
  1.  Q
  1.  ;
  1. GDF(BQDN,BQREF) ;EP - Get basic Definition information
  1.  ;  used mainly for the subdefinitions which can be called
  1.  ;  by the code in the main diagnosis category executable program
  1.  ;
  1.  ;Input
  1.  ;  BQDN  - Diag Cat definition internal entry number
  1.  ;  BQREF - Array reference
  1.  ;Output
  1.  ;  BQDEF  - Definition name
  1.  ;  BQEXEC - Diag Cat special executable program
  1.  ;  BQPRG  - Diag Cat standard executable program
  1.  ;  BQGLB  - Temporary global reference
  1.  ;
  1.  ;  If it's inactive, ignore
  1.  I $$GET1^DIQ(90506.2,BQDN_",",.03,"I")=1 Q
  1.  S BQDEF=$$GET1^DIQ(90506.2,BQDN_",",.01,"E")
  1.  S BQEXEC=$$GET1^DIQ(90506.2,BQDN_",",1,"E")
  1.  S BQPRG=$$GET1^DIQ(90506.2,BQDN_",",.04,"E")
  1.  ;I $G(BQREF)="" S BQREF="BQIRY"
  1.  K @BQREF
  1.  D ARY(BQDEF,BQREF)
  1.  S BQGLB=$NA(^TMP("BQIPOP",UID))
  1.  K @BQGLB
  1.  Q
  1.  ;
  1. GDXN(DEF) ;EP - Get IEN of a definition
  1.  ;Input
  1.  ;  DEF - Diagnosis Category definition name
  1.  ;Output
  1.  ;  Returns the internal entry number of the category definition
  1.  NEW DIC,X,Y
  1.  S DIC(0)="NZ",X=DEF,DIC="^BQI(90506.2,"
  1.  D ^DIC
  1.  Q +Y
  1.  ;
  1. MEAS(BQDFN,MEAS) ;EP - Get measurement
  1.  NEW VALUE,RVDT,QFL,IEN,RES,VISIT,RESULT,VDATE
  1.  I MEAS'?.N S MEAS=$$FIND1^DIC(9999999.07,,"MX",MEAS)
  1.  S VALUE=0
  1.  S RVDT="",QFL=0
  1.  F  S RVDT=$O(^AUPNVMSR("AA",BQDFN,MEAS,RVDT)) Q:RVDT=""  D  Q:QFL
  1.  . S IEN=""
  1.  . F  S IEN=$O(^AUPNVMSR("AA",BQDFN,MEAS,RVDT,IEN)) Q:IEN=""  D  Q:QFL
  1.  .. ; if the new ENTERED IN ERROR field exists, exclude the record if it is marked as an error
  1.  .. I $$VFIELD^DILFD(9000010.01,2) Q:$$GET1^DIQ(9000010.01,IEN_",",2,"I")=1
  1.  .. S RES=$G(^AUPNVMSR(IEN,0)),VISIT=$P(RES,U,3),RESULT=$P(RES,U,4),VDATE=""
  1.  .. I $P($G(^AUPNVMSR(IEN,2)),U,1)=1 Q
  1.  .. I VISIT'="" S VDATE=$P(^AUPNVSIT(VISIT,0),U,1)\1
  1.  .. S VALUE="1^"_VDATE_U_RESULT_U_VISIT_U_IEN,QFL=1
  1.  Q VALUE
  1.  ;
  1. EXAM(BQDFN,EXAM) ;EP - Get exam
  1.  NEW VALUE,RVDT,QFL,IEN,RES,VISIT,RESULT,VDATE
  1.  I EXAM'?.N S EXAM=$$FIND1^DIC(9999999.15,,"MX",EXAM)
  1.  S VALUE=0
  1.  S RVDT="",QFL=0
  1.  F  S RVDT=$O(^AUPNVXAM("AA",BQDFN,EXAM,RVDT)) Q:RVDT=""  D  Q:QFL
  1.  . S IEN=""
  1.  . F  S IEN=$O(^AUPNVXAM("AA",BQDFN,EXAM,RVDT,IEN)) Q:IEN=""  D  Q:QFL
  1.  .. S RES=$G(^AUPNVXAM(IEN,0)),VISIT=$P(RES,U,3),RESULT=$P(RES,U,4),VDATE=""
  1.  .. I VISIT'="" S VDATE=$P(^AUPNVSIT(VISIT,0),U,1)\1
  1.  .. S VALUE="1^"_VDATE_U_RESULT_U_VISIT_U_IEN,QFL=1
  1.  Q VALUE