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