BQIRLB ;PRXM/HC/DLS - Patient Labs ; 18 Jan 2006 11:46 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
Q
;
EN(DATA,DFN,DRANGE,PARMS) ; EP -- BQI PATIENT LABS
;Description
; Generates a Lab Review Report for a Given DFN and Relative Date.
;
;Input
; DFN - Patient Internal ID
; DRANGE - 'From' for pulling Patient Labs (to the present).
; PARMS - Parameters for special filtering
;
;Output
; DATA - Name of global in which data is stored(^TMP("BQIRLB"))
;
NEW UID,X,BQII,LABDT,LABTYP,RLABDT,LABIEN,ORPHY,VISIT,PAR,PNL,SPNLNM
NEW DATE,TEST,RSLT,UNIT,REFLOW,REFHIGH,RANGE,RDRANGE,NRMABN,TST,PNLNM
NEW ASDATA,ASN,ASNAME,ASSOC,ASV,ASVAL,BN,BQ,CGFL,FILTER,II,PDATA,REGIEN
NEW RGFL,RGRP,TAX,TN,TREF,VAL,FDATA
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRLB",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRLB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
F BQ=1:1:$L(PARMS,$C(28)) S FILTER(BQ)=$P(PARMS,$C(28),BQ)
F BQQ=1:1:BQ D
. S PDATA=$G(FILTER(BQQ)) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. S FDATA(BQQ)=NAME
. F II=1:1:$L(VALUE,$C(29)) D
.. S VAL=$P(VALUE,$C(29),II),ASSOC=$P(VAL,$C(25),2,99)
.. S FILTER(BQQ,II)=$P(VAL,$C(25),1)
.. I ASSOC'="" D
... F ASN=1:1:$L(ASSOC,$C(25)) D
.... S ASDATA=$P(ASSOC,$C(25),ASN)
.... S ASVAL=$P(ASDATA,"=",2),ASNAME=$P(ASDATA,"=",1)
.... S FILTER(BQQ,II,ASN)=ASNAME
.... I ASVAL'[$C(24) S FILTER(BQQ,II,ASN,1)=ASVAL Q
.... F ASV=1:1:$L(ASVAL,$C(24)) S FILTER(BQQ,II,ASN,ASV)=$P(ASVAL,$C(24),ASV)
.. I ASSOC="" S FILTER(BQQ,II)=VAL
I $D(FDATA) F BQQ=1:1:BQ S FILTER(BQQ)=FDATA(BQQ)
K FDATA,PARMS
;
NEW BQQ,MBQ,NAME,VALUE,SBQ,MSBQ
K REG,CGRP
S BQQ="",CGFL=0,RGFL=0
F S BQQ=$O(FILTER(BQQ)) Q:BQQ="" D
. ;S NAME=FILTER(BQQ)
. S MBQ=""
. F S MBQ=$O(FILTER(BQQ,MBQ)) Q:MBQ="" D
.. S VALUE=FILTER(BQQ,MBQ),NAME=FILTER(BQQ)
.. ;I NAME="REG" S REG(VALUE)="",RGFL=1
.. I NAME="REG" S RGFL=1
.. S @NAME@(VALUE)=""
.. ;I NAME="CGRP" S CGRP(VALUE)=""
.. S SBQ=""
.. F S SBQ=$O(FILTER(BQQ,MBQ,SBQ)) Q:SBQ="" D
... ;S NAME=FILTER(BQQ,MBQ,SBQ)
... S MSBQ=""
... F S MSBQ=$O(FILTER(BQQ,MBQ,SBQ,MSBQ)) Q:MSBQ="" D
.... S VALUE=FILTER(BQQ,MBQ,SBQ,MSBQ),NAME=FILTER(BQQ,MBQ,SBQ)
.... ;I NAME="CGRP" S CGRP(VALUE)="",CGFL=1
.... I NAME="CGRP" S CGFL=1
.... S @NAME@(VALUE)=""
;
; Get lab taxonomies
S TREF=$NA(^TMP("BQITAX",UID))
K @TREF
S REG=""
F S REG=$O(REG(REG)) Q:REG="" D
. S REGIEN=$$FIND1^DIC(90507,,"MX",REG)
. S TN=0
. F S TN=$O(^BQI(90507,REGIEN,10,TN)) Q:'TN D
.. I $P(^BQI(90507,REGIEN,10,TN,0),U,5)'="T" Q
.. S RGRP=$P(^BQI(90507,REGIEN,10,TN,0),U,7)
.. I CGFL,RGRP'="",'$D(CGRP(RGRP)) Q
.. S TAX=$P(^BQI(90507,REGIEN,10,TN,0),U,1)
.. I $P(^BQI(90507,REGIEN,10,TN,0),U,2)["ATXLAB" D BLD^BQITUTL(TAX,TREF,"L")
.. I $P(^BQI(90507,REGIEN,10,TN,0),U,2)["ATXAX" D BLD^BQITUTL(TAX,TREF)
;
D HDR
S DRANGE=$$DATE^BQIUL1($G(DRANGE))
S LABIEN=""
F S LABIEN=$O(^AUPNVLAB("AC",DFN,LABIEN),-1) Q:LABIEN="" D
. D LAB(LABIEN)
. I $G(VISIT)="" Q
. S RLABDT=$$GET1^DIQ(9000010,VISIT,.01,"I") I RLABDT=0 Q
. S DATE=$$FMTE^BQIUL1(RLABDT)
. I DRANGE'="",(RLABDT\1)<DRANGE Q
. S BQII=BQII+1,@DATA@(BQII)=VISIT_"^"_LABIEN_"^"_DATE_"^"_TEST_"^"_RSLT_"^"_UNIT_"^"_RANGE_"^"_NRMABN_"^"
. S @DATA@(BQII)=@DATA@(BQII)_ORPHY_"^"_PAR_"^"_$S(PNL=1:"Y",1:"N")_"^"_SPNLNM_"^"_PNLNM_$C(30)
;
; Check for refusals
D REF
;
DONE ;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
HDR ;
S @DATA@(BQII)="I00010VISIT_IEN^I00010LAB_IEN^D00030LAB_DATE^T00050LAB_TEST^T00030LAB_RSLT^T00015LAB_UNIT^T00020LAB_RANGE^T00010LAB_NRMABN^"
S @DATA@(BQII)=@DATA@(BQII)_"T00035LAB_ORD_PHYS^I00010PARENT_IEN^T00001PANEL_FLAG^T00050SUB_PANEL_NAME^T00050PAR_PANEL_NAME"_$C(30)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
LAB(LABIEN) ;EP - Get data for a specific lab
S TEST=$$GET1^DIQ(9000010.09,LABIEN,".01","E") I TEST="" Q
S TST=$$GET1^DIQ(9000010.09,LABIEN,".01","I")
;
I $G(RGFL),'$D(@TREF@(TST)) S VISIT="" Q
;I TST="" Q
S RSLT=$$GET1^DIQ(9000010.09,LABIEN,".04","E")
S ORPHY=$$GET1^DIQ(9000010.09,LABIEN,1202,"E")
S UNIT=$$GET1^DIQ(9000010.09,LABIEN,"1101","E")
S REFLOW=$$GET1^DIQ(9000010.09,LABIEN,"1104","E")
S REFHIGH=$$GET1^DIQ(9000010.09,LABIEN,"1105","E")
S RANGE=REFLOW_"-"_REFHIGH
I RANGE="-" S RANGE=""
S NRMABN=$$GET1^DIQ(9000010.09,LABIEN,".05","I")
S VISIT=$$GET1^DIQ(9000010.09,LABIEN,".03","I")
S PNL=0,SPNLNM="",PNLNM=""
I LABIEN=VISIT Q
I $O(^LAB(60,TST,2,0))'="" S PNL=1,SPNLNM=$P($G(^LAB(60,TST,0)),U,1)
S PAR=$$GET1^DIQ(9000010.09,LABIEN,1208,"I")
;
I PAR'="" D
. NEW TST,NPAR
. S TST=$$GET1^DIQ(9000010.09,PAR,".01","I")
. I TST="" Q
. I TST'="" S PNLNM=$P($G(^LAB(60,TST,0)),U,1)
. I $O(^LAB(60,TST,2,0))="" Q
. S NPAR=$$GET1^DIQ(9000010.09,PAR,1208,"I")
. I NPAR'="" D
.. NEW TST
.. S TST=$$GET1^DIQ(9000010.09,NPAR,".01","I")
.. S SPNLNM=PNLNM
.. I TST="" Q
.. I TST'="" S PNLNM=$P($G(^LAB(60,TST,0)),U,1)
I 'PNL,PAR'="",SPNLNM="" S SPNLNM=PNLNM,PNLNM=""
I PNL S TEST=""
I PNL,PAR="" D
. NEW PTS,LTS,SBFL
. S PTS=0,SBFL=0
. F S PTS=$O(^LAB(60,TST,2,PTS)) Q:'PTS D
.. S LTS=$P(^LAB(60,TST,2,PTS,0),U,1)
.. I $O(^LAB(60,LTS,2,0))'="" D
... NEW N
... S N=""
... F S N=$O(^AUPNVLAB("AD",VISIT,N)) Q:N="" D
.... I $P(^AUPNVLAB(N,0),U,1)=LTS S SBFL=1
. I SBFL S PNLNM=SPNLNM,SPNLNM=""
Q
;
REF ; Find refusals
NEW TST,RVDT,REVDT,RFIEN
S TST=""
F S TST=$O(^AUPNPREF("AA",DFN,60,TST)) Q:TST="" D
. S RVDT=""
. F S RVDT=$O(^AUPNPREF("AA",DFN,60,TST,RVDT)) Q:RVDT="" D
.. ; Reverse the reverse date
.. S REVDT=9999999-RVDT
.. I DRANGE'="",(REVDT\1)<DRANGE Q
.. S RFIEN=""
.. F S RFIEN=$O(^AUPNPREF("AA",DFN,60,TST,RVDT,RFIEN)) Q:RFIEN="" D
... S RSLT=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
... S LABIEN=TST
... S DATE=$$FMTE^BQIUL1(REVDT)
... S VISIT="",PAR="",PNL="",UNIT="",RANGE="",NRMABN="",SPNLNM="",PNLNM=""
... S BQII=BQII+1,@DATA@(BQII)=VISIT_"^"_LABIEN_"^"_DATE_"^"_TEST_"^"_RSLT_"^"_UNIT_"^"_RANGE_"^"_NRMABN_"^"
... S @DATA@(BQII)=@DATA@(BQII)_ORPHY_"^"_PAR_"^"_$S(PNL=1:"Y",1:"N")_"^"_SPNLNM_"^"_PNLNM_$C(30)
Q
BQIRLB ;PRXM/HC/DLS - Patient Labs ; 18 Jan 2006 11:46 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 QUIT
+4 ;
EN(DATA,DFN,DRANGE,PARMS) ; EP -- BQI PATIENT LABS
+1 ;Description
+2 ; Generates a Lab Review Report for a Given DFN and Relative Date.
+3 ;
+4 ;Input
+5 ; DFN - Patient Internal ID
+6 ; DRANGE - 'From' for pulling Patient Labs (to the present).
+7 ; PARMS - Parameters for special filtering
+8 ;
+9 ;Output
+10 ; DATA - Name of global in which data is stored(^TMP("BQIRLB"))
+11 ;
+12 NEW UID,X,BQII,LABDT,LABTYP,RLABDT,LABIEN,ORPHY,VISIT,PAR,PNL,SPNLNM
+13 NEW DATE,TEST,RSLT,UNIT,REFLOW,REFHIGH,RANGE,RDRANGE,NRMABN,TST,PNLNM
+14 NEW ASDATA,ASN,ASNAME,ASSOC,ASV,ASVAL,BN,BQ,CGFL,FILTER,II,PDATA,REGIEN
+15 NEW RGFL,RGRP,TAX,TN,TREF,VAL,FDATA
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BQIRLB",UID))
+18 KILL @DATA
+19 ;
+20 SET BQII=0
+21 ;
+22 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRLB D UNWIND^%ZTER"
+23 ;
+24 SET PARMS=$GET(PARMS,"")
+25 IF PARMS=""
Begin DoDot:1
+26 SET LIST=""
SET BN=""
+27 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+28 KILL PARMS
+29 SET PARMS=LIST
+30 KILL LIST
End DoDot:1
+31 ;
+32 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
SET FILTER(BQ)=$PIECE(PARMS,$CHAR(28),BQ)
+33 FOR BQQ=1:1:BQ
Begin DoDot:1
+34 SET PDATA=$GET(FILTER(BQQ))
IF PDATA=""
QUIT
+35 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+36 SET FDATA(BQQ)=NAME
+37 FOR II=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:2
+38 SET VAL=$PIECE(VALUE,$CHAR(29),II)
SET ASSOC=$PIECE(VAL,$CHAR(25),2,99)
+39 SET FILTER(BQQ,II)=$PIECE(VAL,$CHAR(25),1)
+40 IF ASSOC'=""
Begin DoDot:3
+41 FOR ASN=1:1:$LENGTH(ASSOC,$CHAR(25))
Begin DoDot:4
+42 SET ASDATA=$PIECE(ASSOC,$CHAR(25),ASN)
+43 SET ASVAL=$PIECE(ASDATA,"=",2)
SET ASNAME=$PIECE(ASDATA,"=",1)
+44 SET FILTER(BQQ,II,ASN)=ASNAME
+45 IF ASVAL'[$CHAR(24)
SET FILTER(BQQ,II,ASN,1)=ASVAL
QUIT
+46 FOR ASV=1:1:$LENGTH(ASVAL,$CHAR(24))
SET FILTER(BQQ,II,ASN,ASV)=$PIECE(ASVAL,$CHAR(24),ASV)
End DoDot:4
End DoDot:3
+47 IF ASSOC=""
SET FILTER(BQQ,II)=VAL
End DoDot:2
End DoDot:1
+48 IF $DATA(FDATA)
FOR BQQ=1:1:BQ
SET FILTER(BQQ)=FDATA(BQQ)
+49 KILL FDATA,PARMS
+50 ;
+51 NEW BQQ,MBQ,NAME,VALUE,SBQ,MSBQ
+52 KILL REG,CGRP
+53 SET BQQ=""
SET CGFL=0
SET RGFL=0
+54 FOR
SET BQQ=$ORDER(FILTER(BQQ))
IF BQQ=""
QUIT
Begin DoDot:1
+55 ;S NAME=FILTER(BQQ)
+56 SET MBQ=""
+57 FOR
SET MBQ=$ORDER(FILTER(BQQ,MBQ))
IF MBQ=""
QUIT
Begin DoDot:2
+58 SET VALUE=FILTER(BQQ,MBQ)
SET NAME=FILTER(BQQ)
+59 ;I NAME="REG" S REG(VALUE)="",RGFL=1
+60 IF NAME="REG"
SET RGFL=1
+61 SET @NAME@(VALUE)=""
+62 ;I NAME="CGRP" S CGRP(VALUE)=""
+63 SET SBQ=""
+64 FOR
SET SBQ=$ORDER(FILTER(BQQ,MBQ,SBQ))
IF SBQ=""
QUIT
Begin DoDot:3
+65 ;S NAME=FILTER(BQQ,MBQ,SBQ)
+66 SET MSBQ=""
+67 FOR
SET MSBQ=$ORDER(FILTER(BQQ,MBQ,SBQ,MSBQ))
IF MSBQ=""
QUIT
Begin DoDot:4
+68 SET VALUE=FILTER(BQQ,MBQ,SBQ,MSBQ)
SET NAME=FILTER(BQQ,MBQ,SBQ)
+69 ;I NAME="CGRP" S CGRP(VALUE)="",CGFL=1
+70 IF NAME="CGRP"
SET CGFL=1
+71 SET @NAME@(VALUE)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+72 ;
+73 ; Get lab taxonomies
+74 SET TREF=$NAME(^TMP("BQITAX",UID))
+75 KILL @TREF
+76 SET REG=""
+77 FOR
SET REG=$ORDER(REG(REG))
IF REG=""
QUIT
Begin DoDot:1
+78 SET REGIEN=$$FIND1^DIC(90507,,"MX",REG)
+79 SET TN=0
+80 FOR
SET TN=$ORDER(^BQI(90507,REGIEN,10,TN))
IF 'TN
QUIT
Begin DoDot:2
+81 IF $PIECE(^BQI(90507,REGIEN,10,TN,0),U,5)'="T"
QUIT
+82 SET RGRP=$PIECE(^BQI(90507,REGIEN,10,TN,0),U,7)
+83 IF CGFL
IF RGRP'=""
IF '$DATA(CGRP(RGRP))
QUIT
+84 SET TAX=$PIECE(^BQI(90507,REGIEN,10,TN,0),U,1)
+85 IF $PIECE(^BQI(90507,REGIEN,10,TN,0),U,2)["ATXLAB"
DO BLD^BQITUTL(TAX,TREF,"L")
+86 IF $PIECE(^BQI(90507,REGIEN,10,TN,0),U,2)["ATXAX"
DO BLD^BQITUTL(TAX,TREF)
End DoDot:2
End DoDot:1
+87 ;
+88 DO HDR
+89 SET DRANGE=$$DATE^BQIUL1($GET(DRANGE))
+90 SET LABIEN=""
+91 FOR
SET LABIEN=$ORDER(^AUPNVLAB("AC",DFN,LABIEN),-1)
IF LABIEN=""
QUIT
Begin DoDot:1
+92 DO LAB(LABIEN)
+93 IF $GET(VISIT)=""
QUIT
+94 SET RLABDT=$$GET1^DIQ(9000010,VISIT,.01,"I")
IF RLABDT=0
QUIT
+95 SET DATE=$$FMTE^BQIUL1(RLABDT)
+96 IF DRANGE'=""
IF (RLABDT\1)<DRANGE
QUIT
+97 SET BQII=BQII+1
SET @DATA@(BQII)=VISIT_"^"_LABIEN_"^"_DATE_"^"_TEST_"^"_RSLT_"^"_UNIT_"^"_RANGE_"^"_NRMABN_"^"
+98 SET @DATA@(BQII)=@DATA@(BQII)_ORPHY_"^"_PAR_"^"_$SELECT(PNL=1:"Y",1:"N")_"^"_SPNLNM_"^"_PNLNM_$CHAR(30)
End DoDot:1
+99 ;
+100 ; Check for refusals
+101 DO REF
+102 ;
DONE ;
+1 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+2 QUIT
+3 ;
HDR ;
+1 SET @DATA@(BQII)="I00010VISIT_IEN^I00010LAB_IEN^D00030LAB_DATE^T00050LAB_TEST^T00030LAB_RSLT^T00015LAB_UNIT^T00020LAB_RANGE^T00010LAB_NRMABN^"
+2 SET @DATA@(BQII)=@DATA@(BQII)_"T00035LAB_ORD_PHYS^I00010PARENT_IEN^T00001PANEL_FLAG^T00050SUB_PANEL_NAME^T00050PAR_PANEL_NAME"_$CHAR(30)
+3 QUIT
+4 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(BQII)
IF $DATA(DATA)
SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+6 QUIT
+7 ;
LAB(LABIEN) ;EP - Get data for a specific lab
+1 SET TEST=$$GET1^DIQ(9000010.09,LABIEN,".01","E")
IF TEST=""
QUIT
+2 SET TST=$$GET1^DIQ(9000010.09,LABIEN,".01","I")
+3 ;
+4 IF $GET(RGFL)
IF '$DATA(@TREF@(TST))
SET VISIT=""
QUIT
+5 ;I TST="" Q
+6 SET RSLT=$$GET1^DIQ(9000010.09,LABIEN,".04","E")
+7 SET ORPHY=$$GET1^DIQ(9000010.09,LABIEN,1202,"E")
+8 SET UNIT=$$GET1^DIQ(9000010.09,LABIEN,"1101","E")
+9 SET REFLOW=$$GET1^DIQ(9000010.09,LABIEN,"1104","E")
+10 SET REFHIGH=$$GET1^DIQ(9000010.09,LABIEN,"1105","E")
+11 SET RANGE=REFLOW_"-"_REFHIGH
+12 IF RANGE="-"
SET RANGE=""
+13 SET NRMABN=$$GET1^DIQ(9000010.09,LABIEN,".05","I")
+14 SET VISIT=$$GET1^DIQ(9000010.09,LABIEN,".03","I")
+15 SET PNL=0
SET SPNLNM=""
SET PNLNM=""
+16 IF LABIEN=VISIT
QUIT
+17 IF $ORDER(^LAB(60,TST,2,0))'=""
SET PNL=1
SET SPNLNM=$PIECE($GET(^LAB(60,TST,0)),U,1)
+18 SET PAR=$$GET1^DIQ(9000010.09,LABIEN,1208,"I")
+19 ;
+20 IF PAR'=""
Begin DoDot:1
+21 NEW TST,NPAR
+22 SET TST=$$GET1^DIQ(9000010.09,PAR,".01","I")
+23 IF TST=""
QUIT
+24 IF TST'=""
SET PNLNM=$PIECE($GET(^LAB(60,TST,0)),U,1)
+25 IF $ORDER(^LAB(60,TST,2,0))=""
QUIT
+26 SET NPAR=$$GET1^DIQ(9000010.09,PAR,1208,"I")
+27 IF NPAR'=""
Begin DoDot:2
+28 NEW TST
+29 SET TST=$$GET1^DIQ(9000010.09,NPAR,".01","I")
+30 SET SPNLNM=PNLNM
+31 IF TST=""
QUIT
+32 IF TST'=""
SET PNLNM=$PIECE($GET(^LAB(60,TST,0)),U,1)
End DoDot:2
End DoDot:1
+33 IF 'PNL
IF PAR'=""
IF SPNLNM=""
SET SPNLNM=PNLNM
SET PNLNM=""
+34 IF PNL
SET TEST=""
+35 IF PNL
IF PAR=""
Begin DoDot:1
+36 NEW PTS,LTS,SBFL
+37 SET PTS=0
SET SBFL=0
+38 FOR
SET PTS=$ORDER(^LAB(60,TST,2,PTS))
IF 'PTS
QUIT
Begin DoDot:2
+39 SET LTS=$PIECE(^LAB(60,TST,2,PTS,0),U,1)
+40 IF $ORDER(^LAB(60,LTS,2,0))'=""
Begin DoDot:3
+41 NEW N
+42 SET N=""
+43 FOR
SET N=$ORDER(^AUPNVLAB("AD",VISIT,N))
IF N=""
QUIT
Begin DoDot:4
+44 IF $PIECE(^AUPNVLAB(N,0),U,1)=LTS
SET SBFL=1
End DoDot:4
End DoDot:3
End DoDot:2
+45 IF SBFL
SET PNLNM=SPNLNM
SET SPNLNM=""
End DoDot:1
+46 QUIT
+47 ;
REF ; Find refusals
+1 NEW TST,RVDT,REVDT,RFIEN
+2 SET TST=""
+3 FOR
SET TST=$ORDER(^AUPNPREF("AA",DFN,60,TST))
IF TST=""
QUIT
Begin DoDot:1
+4 SET RVDT=""
+5 FOR
SET RVDT=$ORDER(^AUPNPREF("AA",DFN,60,TST,RVDT))
IF RVDT=""
QUIT
Begin DoDot:2
+6 ; Reverse the reverse date
+7 SET REVDT=9999999-RVDT
+8 IF DRANGE'=""
IF (REVDT\1)<DRANGE
QUIT
+9 SET RFIEN=""
+10 FOR
SET RFIEN=$ORDER(^AUPNPREF("AA",DFN,60,TST,RVDT,RFIEN))
IF RFIEN=""
QUIT
Begin DoDot:3
+11 SET RSLT=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
+12 SET ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
+13 SET LABIEN=TST
+14 SET DATE=$$FMTE^BQIUL1(REVDT)
+15 SET VISIT=""
SET PAR=""
SET PNL=""
SET UNIT=""
SET RANGE=""
SET NRMABN=""
SET SPNLNM=""
SET PNLNM=""
+16 SET BQII=BQII+1
SET @DATA@(BQII)=VISIT_"^"_LABIEN_"^"_DATE_"^"_TEST_"^"_RSLT_"^"_UNIT_"^"_RANGE_"^"_NRMABN_"^"
+17 SET @DATA@(BQII)=@DATA@(BQII)_ORPHY_"^"_PAR_"^"_$SELECT(PNL=1:"Y",1:"N")_"^"_SPNLNM_"^"_PNLNM_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
