BQICMUTL ;VNGT/HS/ALA-Care Mgmt Utility ; 25 Jul 2011 7:25 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
;
ITM(TMFRAME,BQDFN,FREF,RREF,TIEN,TAX,TREF) ;EP - Find the value
; Find visits for a request item
; Input
; TMFRAME - Time frame to search data for
; BQDFN - Patient internal entry number
; FREF - File to search in
; RREF - Search file table file
; TIEN - Item to search on
; TAX - Taxonomy
; TREF - Reference array
;
NEW GREF,ENDT,IEN,QFL,RESULT,VISIT,VSDTM,RES,DTM,ITIEN,EDT,BDT,VFL
NEW SRCTYP
S TMFRAME=$G(TMFRAME,"")
I $G(TAX)'="" D
. S TREF=$NA(^TMP($J,"BQITAX")) K @TREF
. I $G(RREF)=60 D BLD^BQITUTL(TAX,TREF,"L") Q
. D BLD^BQITUTL(TAX,TREF)
I $G(TAX)="" D
. I $G(TIEN)="" Q
. S TREF="BQITAX" K @TREF
. S @TREF@(TIEN)=""
S GREF=$$ROOT^DILFD(FREF,"",1)
S VFL=$O(^BQI(90508.6,"B",FREF,""))
I VFL'="" S SRCTYP=$P(^BQI(90508.6,VFL,0),U,3)
S ENDT=$$DATE^BQIUL1(TMFRAME)
S IEN="",QFL=0,RESULT=0
I $G(TMFRAME)'="" D
. S EDT=9999999-ENDT,BDT=""
. I SRCTYP'=2 D Q
.. F S BDT=$O(@GREF@("AA",BQDFN,BDT)) Q:BDT=""!(BDT>EDT) D Q:QFL
... S IEN=""
... F S IEN=$O(@GREF@("AA",BQDFN,BDT,IEN)) Q:IEN="" D Q:QFL
.... S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
.... S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
.... I $G(TIEN)'="",ITIEN'=TIEN Q
.... I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
.... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
.... ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
.... I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
.... ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
.... S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
.... S RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES,QFL=1
. ;
. F S BDT=$O(@GREF@("AA",PTDFN,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
.. S IEN=""
.. F S IEN=$O(@GREF@("AA",PTDFN,TIEN,BDT,IEN)) Q:IEN="" D
... S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
... S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
... I $G(TIEN)'="",ITIEN'=TIEN Q
... I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
... ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
... I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
... ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
... S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
... S RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES,QFL=1
. ; check for refusal
. I $O(^AUPNPREF("AA",BQDFN,RREF,""))'="" D
.. I $D(TREF) S TIEN="" F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
... S EDT=9999999-ENDT,BDT=""
... F S BDT=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT)) Q:BDT=""!(BDT>EDT) D
.... S IEN="" F S IEN=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN)) Q:IEN="" D
..... S DTM=$P(^AUPNPREF(IEN,0),U,3)
..... I $P(RESULT,U,2)'="",DTM<$P(RESULT,U,2) Q
..... S RESULT=1_U_DTM_U_U_U_U_U_"refusal"
;
I $G(TMFRAME)="" D
. S IEN=""
. F S IEN=$O(@GREF@("AC",BQDFN,IEN),-1) Q:IEN="" D Q:QFL
.. S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
.. I $G(TIEN)'="",ITIEN'=TIEN Q
.. I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
.. S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
.. S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
.. ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
.. I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
.. ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
.. S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
.. S RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES,QFL=1
. ; check for refusal
. I $O(^AUPNPREF("AA",BQDFN,RREF,""))'="" D
.. I $D(TREF) S TIEN="" F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
... ;S EDT=(9999999-DT)+.001,BDT=""
... S BDT="",STOP=0
... F S BDT=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT)) Q:BDT="" D Q:STOP
.... S IEN="" F S IEN=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN)) Q:IEN="" D Q:STOP
..... S DTM=$P(^AUPNPREF(IEN,0),U,3)
..... I $P(RESULT,U,2)'="",DTM<$P(RESULT,U,2) Q
..... S RESULT=1_U_DTM_U_U_U_U_U_"refusal",STOP=1
Q RESULT
;
FTAG(TGN,COLN,BQDFN) ; EP - Find the last entry for a value in Tag
; Input Parameters
; TGN - Tag IEN
; COLN - Column IEN
; BQDFN - Patient IEN
;
NEW DA,IENS,FRN,FREF,RREF,ITM,NAM,TAX
S DA(1)=TGN,DA=COLN,IENS=$$IENS^DILF(.DA)
S FRN=$$GET1^DIQ(90506.26,IENS,.02,"I")
S FREF=$$PTR^BQIUL2(90506.26,.02,FRN,.02)
S RREF=$$PTR^BQIUL2(90506.26,.02,FRN,.08)
S ITM=$$GET1^DIQ(90506.26,IENS,.04,"E")
;S DIS=$$GET1^DIQ(90506.26,IENS,.05,"I")
S NAM=$$GET1^DIQ(90506.26,IENS,.03,"E")
S TAX=$$GET1^DIQ(90506.26,IENS,.07,"E")
Q $$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,"")
;
FND(CRN,COLN,BQDFN) ;EP - Find the last entry for a value in Source
; Input Parameters
; CRN - Care Mgmt Source IEN
; COLN - Column IEN
; BQDFN - Patient IEN
;
NEW DA,IENS,FRN,FREF,RREF,ITM,NAM,TAX,EXEC,NONT,APCHSDFN,APCHSPAT
S (APCHSDFN,APCHSPAT)=BQDFN
S DA(1)=CRN,DA=COLN,IENS=$$IENS^DILF(.DA)
S FRN=$$GET1^DIQ(90506.51,IENS,.02,"I")
S FREF=$$PTR^BQIUL2(90506.51,.02,FRN,.02)
S RREF=$$PTR^BQIUL2(90506.51,.02,FRN,.08)
S ITM=$$GET1^DIQ(90506.51,IENS,.04,"E")
;S DIS=$$GET1^DIQ(90506.51,IENS,.05,"I")
S NAM=$$GET1^DIQ(90506.51,IENS,.03,"E")
S TAX=$$GET1^DIQ(90506.51,IENS,.07,"E")
S EXEC=$$GET1^DIQ(90506.51,IENS,1,"E")
S NONT=$$GET1^DIQ(90506.51,IENS,2,"E")
I EXEC'="" X EXEC
I EXEC'="",EXEC["VAL" Q VAL
I EXEC'="",EXEC["RESULT" Q RESULT
I NONT'="" X NONT
Q $$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,.TREF)
;
SKN ;EP - Skin Test
S TIEN=$O(^AUTTSK("B","PPD","")) I TIEN="" Q
S BTREF(TIEN)="PPD",TREF=$NA(BTREF)
Q
;
TB ;EP - Quantiferon lab
NEW TAX
S TREF=$NA(BTREF) K @TREF
S TAX="BQI TB QUANTIFERON LOINC" D BLD^BQITUTL(TAX,.TREF)
S TAX="BQI TB QUANTIFERON TEST" D BLD^BQITUTL(TAX,.TREF,"L")
Q
;
SER(TAX,RESULT) ;EP - Find a series
NEW TREF,TIEN
S TREF=$NA(^TMP($J,"BQITAX")) K @TREF
D BLD^BQITUTL(TAX,TREF)
S GREF=$$ROOT^DILFD(FREF,"",1),RREF=FREF
S IEN="",QFL=0,CT=0,RESULT=CT
F S IEN=$O(@GREF@("AC",BQDFN,IEN),-1) Q:'IEN D
. S ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I") I ITIEN="" Q
. I $G(TIEN)'="",ITIEN'=TIEN Q
. I $G(TIEN)="",'$D(@TREF@(ITIEN)) Q
. S RES=$$GET1^DIQ(FREF,IEN,.04,"I")
. S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I") I VISIT="" Q
. ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
. I $P($G(^AUPNVSIT(VISIT,0)),"^",11)=1 Q
. ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
. S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),"^",1)\1 I VSDTM=0 Q
. S CT=CT+1,RESULT=CT
. S RESULT(CT)=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES
; check for refusal
I $O(^AUPNPREF("AA",BQDFN,RREF,""))'="" D
. I $D(TREF) S TIEN="" F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
.. S BDT="",STOP=0
.. F S BDT=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT)) Q:BDT="" D
... S IEN="" F S IEN=$O(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN)) Q:IEN="" D
.... S DTM=$P(^AUPNPREF(IEN,0),U,3)
.... I $P(RESULT,U,2)'="",DTM<$P(RESULT,U,2) Q
.... S CT=CT+1,RESULT=CT
.... S RESULT(CT)=1_U_DTM_U_U_U_U_U_"refusal"
I RESULT="" Q
NEW NRES,BQDTFRM,NCT
S NRES=""
S BQDTFRM=$$GET1^DIQ(90506.51,IENS,.08,"I") S:BQDTFRM="" BQDTFRM="S"
S NCT=""
F S NCT=$O(RESULT(NCT),-1) Q:NCT="" D
. 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)
. I $P(RESULT(NCT),U,8)="refusal" S NRES=NRES_"(refusal)"_$C(13)_$C(10)
K RESULT S RESULT=NRES
Q
;
EX(TYPE,RIEN,FIELD,RESULT) ;EP
NEW MDATA
I TYPE="PR" D
. S RESULT=""
. I FIELD=.01 D Q
.. S DN=$$GET1^DIQ(9000011,RIEN_",",FIELD,"I")
.. I $$VERSION^XPDUTL("AICD")>3.51 S RESULT=1_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]" Q
.. S RESULT=1_U_$P(^ICD9(DN,0),U,3)_" ["_$P(^ICD9(DN,0),U,1)_"]"
. I FIELD="ONSET" D Q
.. S MDATA=$$PROB^BQIUL1(RIEN) I MDATA="" S RESULT=0
.. S RESULT=1_U_MDATA
. I DIS="D" S RESULT=1_U_$$GET1^DIQ(9000011,RIEN_",",FIELD,"I") Q
. S RESULT=1_U_$$GET1^DIQ(9000011,RIEN_",",FIELD,"E")
. I RESULT="" S RESULT=0
I TYPE="AL" D
. NEW ARIEN
. S RESULT=""
. I FIELD=4 S RESULT=1_U_$$GET1^DIQ(120.8,RIEN_",",FIELD,"I") Q
. 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
. S RESULT=1_U_$$GET1^DIQ(120.8,RIEN_",",FIELD,"E")
. I RESULT="" S RESULT=0
I TYPE="ME" D Q
. NEW FILE
. S FILE=9000010.14,RESULT=""
. I FIELD="DATE" D
.. S RES=$$VISD(FILE,RIEN)
.. I RES'="" S RESULT=1_U_(RES\1)
. I FIELD?.N!(FIELD?1".".N) D Q
.. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
. S RXN=$$GET1^DIQ(9000010.14,RIEN_",",1102,"E") I RXN="" Q
. S RXIEN=$O(^PSRX("B",RXN,"")) I RXIEN="" Q
. I FIELD="STAT" S RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",100,"E")
. I FIELD="NREF" S RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",9,"E")
. I FIELD="LDDT" S RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",101,"I")
. I RESULT="" S RESULT=0
I TYPE="CP" D Q
. NEW FILE
. S FILE=9000010.18,RESULT=""
. I FIELD?.N!(FIELD?1".".N) D Q
.. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
. I FIELD="DATE" D
.. S RES=$$VISD(FILE,RIEN)
.. I RES'="" S RESULT=1_U_(RES\1)
. I FIELD="CPT" D
.. S DN=$P($G(^AUPNVCPT(RIEN,0)),U,1) I DN="" Q
.. S RESULT=1_U_$P(^ICPT(DN,0),U,1)_" - "_$P(^ICPT(DN,0),U,2)
. I RESULT="" S RESULT=0
I TYPE="ER" D Q
. NEW FILE
. S FILE=9009080,RESULT=""
. I FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N) D Q
.. I DFN=RIEN,FIELD'=.05 Q
.. I DFN=RIEN,FIELD=.05 S RESULT=1_U_$$GET1^DIQ(9009081,RIEN_",",3,"E") Q
.. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
. I FIELD="ADATE" D
.. I DFN=RIEN S RESULT=1_U_$P($G(^AMERADM(RIEN,0)),U,2)\1 Q
.. S RESULT=1_U_$P($G(^AMERVSIT(RIEN,0)),U,1)
. I FIELD="DDATE" D
.. I DFN=RIEN Q
.. S RESULT=1_U_$P($G(^AMERVSIT(RIEN,6)),U,2)
. I FIELD="MODE" D
.. I DFN=RIEN S RESULT=1_U_$$GET1^DIQ(9009081,RIEN_",",6,"E") Q
.. NEW MODE
.. S MODE=$$GET1^DIQ(FILE,RIEN_",",.25,"E")
.. I MODE="" S MODE=$$GET1^DIQ(FILE,RIEN_",",17.3,"E")
.. I MODE'="" S RESULT=1_U_MODE
. I RESULT="" S RESULT=0
I TYPE="LA" D Q
. NEW FILE,TEXT,LN,RES
. S FILE=9000010.09,RESULT=""
. I FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N) D Q
.. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
. I FIELD="COM" D Q
.. S TEXT="",LN=0
.. F S LN=$O(^AUPNVLAB(RIEN,21,LN)) Q:'LN D
... S TEXT=TEXT_^AUPNVLAB(RIEN,21,LN,0)_$C(10)_$C(13)
.. S RESULT=1_U_$$TKO^BQIUL1(TEXT,$C(10)_$C(13))
. I FIELD="DATE" D
.. ;S VISIT=$P($G(^AUPNVLAB(RIEN,0)),U,3) I VISIT="" Q
.. S RES=$$VISD(FILE,RIEN)
.. I RES'="" S RESULT=1_U_(RES\1)
. I RESULT="" S RESULT=0
I TYPE="ED" D Q
. NEW FILE,RES
. S FILE=9000010.16,RESULT=""
. I FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N) D Q
.. S RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
. I FIELD="DATE" D
.. S RES=$$VISD(FILE,RIEN)
.. I RES'="" S RESULT=1_U_(RES\1)
. I RESULT="" S RESULT=0
Q
;
VISD(FILE,RIEN) ; EP - Get visit date
NEW VFILE
S VFILE=$$ROOT^DILFD(FILE,"",1)
S VISIT=$P($G(@VFILE@(RIEN,0)),U,3) I VISIT="" Q ""
Q $P($G(^AUPNVSIT(VISIT,0)),U,1)
;
ORD ;EP - Display Order
NEW BQSRC
S BQSRC=$$GET1^DIQ(90506.1,D0_",",3.01,"I")
S BQSRC=$$PTR^BQIUL2(90506.1,3.01,BQSRC,.02)
W "Previous Order: ",$O(^BQI(90506.1,"AD",BQSRC,""),-1)
Q
BQICMUTL ;VNGT/HS/ALA-Care Mgmt Utility ; 25 Jul 2011 7:25 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 ;
ITM(TMFRAME,BQDFN,FREF,RREF,TIEN,TAX,TREF) ;EP - Find the value
+1 ; Find visits for a request item
+2 ; Input
+3 ; TMFRAME - Time frame to search data for
+4 ; BQDFN - Patient internal entry number
+5 ; FREF - File to search in
+6 ; RREF - Search file table file
+7 ; TIEN - Item to search on
+8 ; TAX - Taxonomy
+9 ; TREF - Reference array
+10 ;
+11 NEW GREF,ENDT,IEN,QFL,RESULT,VISIT,VSDTM,RES,DTM,ITIEN,EDT,BDT,VFL
+12 NEW SRCTYP
+13 SET TMFRAME=$GET(TMFRAME,"")
+14 IF $GET(TAX)'=""
Begin DoDot:1
+15 SET TREF=$NAME(^TMP($JOB,"BQITAX"))
KILL @TREF
+16 IF $GET(RREF)=60
DO BLD^BQITUTL(TAX,TREF,"L")
QUIT
+17 DO BLD^BQITUTL(TAX,TREF)
End DoDot:1
+18 IF $GET(TAX)=""
Begin DoDot:1
+19 IF $GET(TIEN)=""
QUIT
+20 SET TREF="BQITAX"
KILL @TREF
+21 SET @TREF@(TIEN)=""
End DoDot:1
+22 SET GREF=$$ROOT^DILFD(FREF,"",1)
+23 SET VFL=$ORDER(^BQI(90508.6,"B",FREF,""))
+24 IF VFL'=""
SET SRCTYP=$PIECE(^BQI(90508.6,VFL,0),U,3)
+25 SET ENDT=$$DATE^BQIUL1(TMFRAME)
+26 SET IEN=""
SET QFL=0
SET RESULT=0
+27 IF $GET(TMFRAME)'=""
Begin DoDot:1
+28 SET EDT=9999999-ENDT
SET BDT=""
+29 IF SRCTYP'=2
Begin DoDot:2
+30 FOR
SET BDT=$ORDER(@GREF@("AA",BQDFN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:3
+31 SET IEN=""
+32 FOR
SET IEN=$ORDER(@GREF@("AA",BQDFN,BDT,IEN))
IF IEN=""
QUIT
Begin DoDot:4
+33 SET ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I")
IF ITIEN=""
QUIT
+34 SET RES=$$GET1^DIQ(FREF,IEN,.04,"I")
+35 IF $GET(TIEN)'=""
IF ITIEN'=TIEN
QUIT
+36 IF $GET(TIEN)=""
IF '$DATA(@TREF@(ITIEN))
QUIT
+37 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")
IF VISIT=""
QUIT
+38 ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
+39 IF $PIECE($GET(^AUPNVSIT(VISIT,0)),"^",11)=1
QUIT
+40 ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
+41 SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),"^",1)\1
IF VSDTM=0
QUIT
+42 SET RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES
SET QFL=1
End DoDot:4
IF QFL
QUIT
End DoDot:3
IF QFL
QUIT
End DoDot:2
QUIT
+43 ;
+44 FOR
SET BDT=$ORDER(@GREF@("AA",PTDFN,TIEN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:2
+45 SET IEN=""
+46 FOR
SET IEN=$ORDER(@GREF@("AA",PTDFN,TIEN,BDT,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+47 SET ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I")
IF ITIEN=""
QUIT
+48 SET RES=$$GET1^DIQ(FREF,IEN,.04,"I")
+49 IF $GET(TIEN)'=""
IF ITIEN'=TIEN
QUIT
+50 IF $GET(TIEN)=""
IF '$DATA(@TREF@(ITIEN))
QUIT
+51 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")
IF VISIT=""
QUIT
+52 ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
+53 IF $PIECE($GET(^AUPNVSIT(VISIT,0)),"^",11)=1
QUIT
+54 ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
+55 SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),"^",1)\1
IF VSDTM=0
QUIT
+56 SET RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES
SET QFL=1
End DoDot:3
End DoDot:2
+57 ; check for refusal
+58 IF $ORDER(^AUPNPREF("AA",BQDFN,RREF,""))'=""
Begin DoDot:2
+59 IF $DATA(TREF)
SET TIEN=""
FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF TIEN=""
QUIT
Begin DoDot:3
+60 SET EDT=9999999-ENDT
SET BDT=""
+61 FOR
SET BDT=$ORDER(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT))
IF BDT=""!(BDT>EDT)
QUIT
Begin DoDot:4
+62 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN))
IF IEN=""
QUIT
Begin DoDot:5
+63 SET DTM=$PIECE(^AUPNPREF(IEN,0),U,3)
+64 IF $PIECE(RESULT,U,2)'=""
IF DTM<$PIECE(RESULT,U,2)
QUIT
+65 SET RESULT=1_U_DTM_U_U_U_U_U_"refusal"
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+66 ;
+67 IF $GET(TMFRAME)=""
Begin DoDot:1
+68 SET IEN=""
+69 FOR
SET IEN=$ORDER(@GREF@("AC",BQDFN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:2
+70 SET ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I")
IF ITIEN=""
QUIT
+71 IF $GET(TIEN)'=""
IF ITIEN'=TIEN
QUIT
+72 IF $GET(TIEN)=""
IF '$DATA(@TREF@(ITIEN))
QUIT
+73 SET RES=$$GET1^DIQ(FREF,IEN,.04,"I")
+74 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")
IF VISIT=""
QUIT
+75 ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
+76 IF $PIECE($GET(^AUPNVSIT(VISIT,0)),"^",11)=1
QUIT
+77 ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
+78 SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),"^",1)\1
IF VSDTM=0
QUIT
+79 SET RESULT=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES
SET QFL=1
End DoDot:2
IF QFL
QUIT
+80 ; check for refusal
+81 IF $ORDER(^AUPNPREF("AA",BQDFN,RREF,""))'=""
Begin DoDot:2
+82 IF $DATA(TREF)
SET TIEN=""
FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF TIEN=""
QUIT
Begin DoDot:3
+83 ;S EDT=(9999999-DT)+.001,BDT=""
+84 SET BDT=""
SET STOP=0
+85 FOR
SET BDT=$ORDER(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT))
IF BDT=""
QUIT
Begin DoDot:4
+86 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN))
IF IEN=""
QUIT
Begin DoDot:5
+87 SET DTM=$PIECE(^AUPNPREF(IEN,0),U,3)
+88 IF $PIECE(RESULT,U,2)'=""
IF DTM<$PIECE(RESULT,U,2)
QUIT
+89 SET RESULT=1_U_DTM_U_U_U_U_U_"refusal"
SET STOP=1
End DoDot:5
IF STOP
QUIT
End DoDot:4
IF STOP
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+90 QUIT RESULT
+91 ;
FTAG(TGN,COLN,BQDFN) ; EP - Find the last entry for a value in Tag
+1 ; Input Parameters
+2 ; TGN - Tag IEN
+3 ; COLN - Column IEN
+4 ; BQDFN - Patient IEN
+5 ;
+6 NEW DA,IENS,FRN,FREF,RREF,ITM,NAM,TAX
+7 SET DA(1)=TGN
SET DA=COLN
SET IENS=$$IENS^DILF(.DA)
+8 SET FRN=$$GET1^DIQ(90506.26,IENS,.02,"I")
+9 SET FREF=$$PTR^BQIUL2(90506.26,.02,FRN,.02)
+10 SET RREF=$$PTR^BQIUL2(90506.26,.02,FRN,.08)
+11 SET ITM=$$GET1^DIQ(90506.26,IENS,.04,"E")
+12 ;S DIS=$$GET1^DIQ(90506.26,IENS,.05,"I")
+13 SET NAM=$$GET1^DIQ(90506.26,IENS,.03,"E")
+14 SET TAX=$$GET1^DIQ(90506.26,IENS,.07,"E")
+15 QUIT $$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,"")
+16 ;
FND(CRN,COLN,BQDFN) ;EP - Find the last entry for a value in Source
+1 ; Input Parameters
+2 ; CRN - Care Mgmt Source IEN
+3 ; COLN - Column IEN
+4 ; BQDFN - Patient IEN
+5 ;
+6 NEW DA,IENS,FRN,FREF,RREF,ITM,NAM,TAX,EXEC,NONT,APCHSDFN,APCHSPAT
+7 SET (APCHSDFN,APCHSPAT)=BQDFN
+8 SET DA(1)=CRN
SET DA=COLN
SET IENS=$$IENS^DILF(.DA)
+9 SET FRN=$$GET1^DIQ(90506.51,IENS,.02,"I")
+10 SET FREF=$$PTR^BQIUL2(90506.51,.02,FRN,.02)
+11 SET RREF=$$PTR^BQIUL2(90506.51,.02,FRN,.08)
+12 SET ITM=$$GET1^DIQ(90506.51,IENS,.04,"E")
+13 ;S DIS=$$GET1^DIQ(90506.51,IENS,.05,"I")
+14 SET NAM=$$GET1^DIQ(90506.51,IENS,.03,"E")
+15 SET TAX=$$GET1^DIQ(90506.51,IENS,.07,"E")
+16 SET EXEC=$$GET1^DIQ(90506.51,IENS,1,"E")
+17 SET NONT=$$GET1^DIQ(90506.51,IENS,2,"E")
+18 IF EXEC'=""
XECUTE EXEC
+19 IF EXEC'=""
IF EXEC["VAL"
QUIT VAL
+20 IF EXEC'=""
IF EXEC["RESULT"
QUIT RESULT
+21 IF NONT'=""
XECUTE NONT
+22 QUIT $$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,.TREF)
+23 ;
SKN ;EP - Skin Test
+1 SET TIEN=$ORDER(^AUTTSK("B","PPD",""))
IF TIEN=""
QUIT
+2 SET BTREF(TIEN)="PPD"
SET TREF=$NAME(BTREF)
+3 QUIT
+4 ;
TB ;EP - Quantiferon lab
+1 NEW TAX
+2 SET TREF=$NAME(BTREF)
KILL @TREF
+3 SET TAX="BQI TB QUANTIFERON LOINC"
DO BLD^BQITUTL(TAX,.TREF)
+4 SET TAX="BQI TB QUANTIFERON TEST"
DO BLD^BQITUTL(TAX,.TREF,"L")
+5 QUIT
+6 ;
SER(TAX,RESULT) ;EP - Find a series
+1 NEW TREF,TIEN
+2 SET TREF=$NAME(^TMP($JOB,"BQITAX"))
KILL @TREF
+3 DO BLD^BQITUTL(TAX,TREF)
+4 SET GREF=$$ROOT^DILFD(FREF,"",1)
SET RREF=FREF
+5 SET IEN=""
SET QFL=0
SET CT=0
SET RESULT=CT
+6 FOR
SET IEN=$ORDER(@GREF@("AC",BQDFN,IEN),-1)
IF 'IEN
QUIT
Begin DoDot:1
+7 SET ITIEN=$$GET1^DIQ(FREF,IEN,.01,"I")
IF ITIEN=""
QUIT
+8 IF $GET(TIEN)'=""
IF ITIEN'=TIEN
QUIT
+9 IF $GET(TIEN)=""
IF '$DATA(@TREF@(ITIEN))
QUIT
+10 SET RES=$$GET1^DIQ(FREF,IEN,.04,"I")
+11 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")
IF VISIT=""
QUIT
+12 ;I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
+13 IF $PIECE($GET(^AUPNVSIT(VISIT,0)),"^",11)=1
QUIT
+14 ;S VSDTM=$$GET1^DIQ(9000010,VISIT,.01,"I")\1 Q:VSDTM=0
+15 SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),"^",1)\1
IF VSDTM=0
QUIT
+16 SET CT=CT+1
SET RESULT=CT
+17 SET RESULT(CT)=1_U_VSDTM_U_U_VISIT_U_IEN_U_RES
End DoDot:1
+18 ; check for refusal
+19 IF $ORDER(^AUPNPREF("AA",BQDFN,RREF,""))'=""
Begin DoDot:1
+20 IF $DATA(TREF)
SET TIEN=""
FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF TIEN=""
QUIT
Begin DoDot:2
+21 SET BDT=""
SET STOP=0
+22 FOR
SET BDT=$ORDER(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT))
IF BDT=""
QUIT
Begin DoDot:3
+23 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPREF("AA",BQDFN,RREF,TIEN,BDT,IEN))
IF IEN=""
QUIT
Begin DoDot:4
+24 SET DTM=$PIECE(^AUPNPREF(IEN,0),U,3)
+25 IF $PIECE(RESULT,U,2)'=""
IF DTM<$PIECE(RESULT,U,2)
QUIT
+26 SET CT=CT+1
SET RESULT=CT
+27 SET RESULT(CT)=1_U_DTM_U_U_U_U_U_"refusal"
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF RESULT=""
QUIT
+29 NEW NRES,BQDTFRM,NCT
+30 SET NRES=""
+31 SET BQDTFRM=$$GET1^DIQ(90506.51,IENS,.08,"I")
IF BQDTFRM=""
SET BQDTFRM="S"
+32 SET NCT=""
+33 FOR
SET NCT=$ORDER(RESULT(NCT),-1)
IF NCT=""
QUIT
Begin DoDot:1
+34 SET NRES=NRES_$SELECT(BQDTFRM="S":$$FMTE^BQIUL1($PIECE(RESULT(NCT),U,2)),1:$$FMTMDY^BQIUL1($PIECE(RESULT(NCT),U,2)))_$CHAR(13)_$CHAR(10)
+35 IF $PIECE(RESULT(NCT),U,8)="refusal"
SET NRES=NRES_"(refusal)"_$CHAR(13)_$CHAR(10)
End DoDot:1
+36 KILL RESULT
SET RESULT=NRES
+37 QUIT
+38 ;
EX(TYPE,RIEN,FIELD,RESULT) ;EP
+1 NEW MDATA
+2 IF TYPE="PR"
Begin DoDot:1
+3 SET RESULT=""
+4 IF FIELD=.01
Begin DoDot:2
+5 SET DN=$$GET1^DIQ(9000011,RIEN_",",FIELD,"I")
+6 IF $$VERSION^XPDUTL("AICD")>3.51
SET RESULT=1_U_$$VST^ICDCODE(DN,"",80)_" ["_$$CODEC^ICDCODE(DN,80)_"]"
QUIT
+7 SET RESULT=1_U_$PIECE(^ICD9(DN,0),U,3)_" ["_$PIECE(^ICD9(DN,0),U,1)_"]"
End DoDot:2
QUIT
+8 IF FIELD="ONSET"
Begin DoDot:2
+9 SET MDATA=$$PROB^BQIUL1(RIEN)
IF MDATA=""
SET RESULT=0
+10 SET RESULT=1_U_MDATA
End DoDot:2
QUIT
+11 IF DIS="D"
SET RESULT=1_U_$$GET1^DIQ(9000011,RIEN_",",FIELD,"I")
QUIT
+12 SET RESULT=1_U_$$GET1^DIQ(9000011,RIEN_",",FIELD,"E")
+13 IF RESULT=""
SET RESULT=0
End DoDot:1
+14 IF TYPE="AL"
Begin DoDot:1
+15 NEW ARIEN
+16 SET RESULT=""
+17 IF FIELD=4
SET RESULT=1_U_$$GET1^DIQ(120.8,RIEN_",",FIELD,"I")
QUIT
+18 IF FIELD=14.5
SET ARIEN=$ORDER(^GMR(120.85,"C",RIEN,""))
IF ARIEN'=""
SET RESULT=1_U_$$GET1^DIQ(120.85,ARIEN_",",FIELD,"E")
QUIT
+19 SET RESULT=1_U_$$GET1^DIQ(120.8,RIEN_",",FIELD,"E")
+20 IF RESULT=""
SET RESULT=0
End DoDot:1
+21 IF TYPE="ME"
Begin DoDot:1
+22 NEW FILE
+23 SET FILE=9000010.14
SET RESULT=""
+24 IF FIELD="DATE"
Begin DoDot:2
+25 SET RES=$$VISD(FILE,RIEN)
+26 IF RES'=""
SET RESULT=1_U_(RES\1)
End DoDot:2
+27 IF FIELD?.N!(FIELD?1".".N)
Begin DoDot:2
+28 SET RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
End DoDot:2
QUIT
+29 SET RXN=$$GET1^DIQ(9000010.14,RIEN_",",1102,"E")
IF RXN=""
QUIT
+30 SET RXIEN=$ORDER(^PSRX("B",RXN,""))
IF RXIEN=""
QUIT
+31 IF FIELD="STAT"
SET RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",100,"E")
+32 IF FIELD="NREF"
SET RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",9,"E")
+33 IF FIELD="LDDT"
SET RESULT=1_U_$$GET1^DIQ(52,RXIEN_",",101,"I")
+34 IF RESULT=""
SET RESULT=0
End DoDot:1
QUIT
+35 IF TYPE="CP"
Begin DoDot:1
+36 NEW FILE
+37 SET FILE=9000010.18
SET RESULT=""
+38 IF FIELD?.N!(FIELD?1".".N)
Begin DoDot:2
+39 SET RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
End DoDot:2
QUIT
+40 IF FIELD="DATE"
Begin DoDot:2
+41 SET RES=$$VISD(FILE,RIEN)
+42 IF RES'=""
SET RESULT=1_U_(RES\1)
End DoDot:2
+43 IF FIELD="CPT"
Begin DoDot:2
+44 SET DN=$PIECE($GET(^AUPNVCPT(RIEN,0)),U,1)
IF DN=""
QUIT
+45 SET RESULT=1_U_$PIECE(^ICPT(DN,0),U,1)_" - "_$PIECE(^ICPT(DN,0),U,2)
End DoDot:2
+46 IF RESULT=""
SET RESULT=0
End DoDot:1
QUIT
+47 IF TYPE="ER"
Begin DoDot:1
+48 NEW FILE
+49 SET FILE=9009080
SET RESULT=""
+50 IF FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N)
Begin DoDot:2
+51 IF DFN=RIEN
IF FIELD'=.05
QUIT
+52 IF DFN=RIEN
IF FIELD=.05
SET RESULT=1_U_$$GET1^DIQ(9009081,RIEN_",",3,"E")
QUIT
+53 SET RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
End DoDot:2
QUIT
+54 IF FIELD="ADATE"
Begin DoDot:2
+55 IF DFN=RIEN
SET RESULT=1_U_$PIECE($GET(^AMERADM(RIEN,0)),U,2)\1
QUIT
+56 SET RESULT=1_U_$PIECE($GET(^AMERVSIT(RIEN,0)),U,1)
End DoDot:2
+57 IF FIELD="DDATE"
Begin DoDot:2
+58 IF DFN=RIEN
QUIT
+59 SET RESULT=1_U_$PIECE($GET(^AMERVSIT(RIEN,6)),U,2)
End DoDot:2
+60 IF FIELD="MODE"
Begin DoDot:2
+61 IF DFN=RIEN
SET RESULT=1_U_$$GET1^DIQ(9009081,RIEN_",",6,"E")
QUIT
+62 NEW MODE
+63 SET MODE=$$GET1^DIQ(FILE,RIEN_",",.25,"E")
+64 IF MODE=""
SET MODE=$$GET1^DIQ(FILE,RIEN_",",17.3,"E")
+65 IF MODE'=""
SET RESULT=1_U_MODE
End DoDot:2
+66 IF RESULT=""
SET RESULT=0
End DoDot:1
QUIT
+67 IF TYPE="LA"
Begin DoDot:1
+68 NEW FILE,TEXT,LN,RES
+69 SET FILE=9000010.09
SET RESULT=""
+70 IF FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N)
Begin DoDot:2
+71 SET RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
End DoDot:2
QUIT
+72 IF FIELD="COM"
Begin DoDot:2
+73 SET TEXT=""
SET LN=0
+74 FOR
SET LN=$ORDER(^AUPNVLAB(RIEN,21,LN))
IF 'LN
QUIT
Begin DoDot:3
+75 SET TEXT=TEXT_^AUPNVLAB(RIEN,21,LN,0)_$CHAR(10)_$CHAR(13)
End DoDot:3
+76 SET RESULT=1_U_$$TKO^BQIUL1(TEXT,$CHAR(10)_$CHAR(13))
End DoDot:2
QUIT
+77 IF FIELD="DATE"
Begin DoDot:2
+78 ;S VISIT=$P($G(^AUPNVLAB(RIEN,0)),U,3) I VISIT="" Q
+79 SET RES=$$VISD(FILE,RIEN)
+80 IF RES'=""
SET RESULT=1_U_(RES\1)
End DoDot:2
+81 IF RESULT=""
SET RESULT=0
End DoDot:1
QUIT
+82 IF TYPE="ED"
Begin DoDot:1
+83 NEW FILE,RES
+84 SET FILE=9000010.16
SET RESULT=""
+85 IF FIELD?.N!(FIELD?1".".N)!(FIELD?.N1".".N)
Begin DoDot:2
+86 SET RESULT=1_U_$$GET1^DIQ(FILE,RIEN_",",FIELD,"E")
End DoDot:2
QUIT
+87 IF FIELD="DATE"
Begin DoDot:2
+88 SET RES=$$VISD(FILE,RIEN)
+89 IF RES'=""
SET RESULT=1_U_(RES\1)
End DoDot:2
+90 IF RESULT=""
SET RESULT=0
End DoDot:1
QUIT
+91 QUIT
+92 ;
VISD(FILE,RIEN) ; EP - Get visit date
+1 NEW VFILE
+2 SET VFILE=$$ROOT^DILFD(FILE,"",1)
+3 SET VISIT=$PIECE($GET(@VFILE@(RIEN,0)),U,3)
IF VISIT=""
QUIT ""
+4 QUIT $PIECE($GET(^AUPNVSIT(VISIT,0)),U,1)
+5 ;
ORD ;EP - Display Order
+1 NEW BQSRC
+2 SET BQSRC=$$GET1^DIQ(90506.1,D0_",",3.01,"I")
+3 SET BQSRC=$$PTR^BQIUL2(90506.1,3.01,BQSRC,.02)
+4 WRITE "Previous Order: ",$ORDER(^BQI(90506.1,"AD",BQSRC,""),-1)
+5 QUIT
