BQICMUT2 ;GDHD/HCS/ALA-Care Mgmt Utility ; 02 Nov 2016 9:53 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;;
;
MEAS(DFN,MEAS) ;EP - Last Measurement
NEW VALUE,RES
S VALUE=$$MEAS^BQITUTL(DFN,MEAS)
I 'VALUE Q ""
S RES=$P(VALUE,"^",3) I MEAS="BMI" S RES=$J(RES,3,2)
S VALUE=$$FMTMDY^BQIUL1($P(VALUE,"^",2))_" ("_RES_")"
Q VALUE
;
LEAD(DFN) ;EP - Lead test
NEW VALUE
S VALUE=$$LAB^BQITRUTL("",0,DFN,"BQI BLOOD LEAD TESTS","","'=","","","")
I 'VALUE Q ""
Q $P(VALUE,U,2)_" ("_$P(VALUE,U,3)_")"
;
INF(DFN,AGE,FFLG) ;EP - Infant Feeding record
NEW VALUE,FIEN,DOB,BD1,BD2,STRT,DATE
S VALUE="",FFLG=$G(FFLG,0)
I $G(AGE)="" D Q VALUE
. S FIEN=$O(^AUPNVIF("AC",DFN,""),-1) I FIEN="" Q
. D INV
;
S VALUE="NO"
S DOB=$P(^DPT(DFN,0),"^",3)
I AGE="2 MOS" S B1=45,B2=89
I AGE="6 MOS" S B1=165,B2=209
I AGE="9 MOS" S B1=255,B2=299
I AGE="12 MOS" S B1=350,B2=394
S BD1=$$FMADD^XLFDT(DOB,B1),BD2=$$FMADD^XLFDT(DOB,B2)
S STRT=""
F S STRT=$O(^AUPNVIF("AA",DFN,STRT)) Q:STRT="" D
. S DATE=9999999-STRT
. I DATE'<BD1,DATE'>BD2 S FIEN=$O(^AUPNVIF("AA",DFN,STRT,"")) D INV
Q VALUE
;
DENT(DFN) ;EP - Last Dental Visit
NEW VALUE,BDATE,EDATE,P,ORD,N,BGPG,BQIXX,BGPC,DATE
S VALUE=""
S BDATE=$$DATE^BQIUL1("T-60M"),EDATE=DT,P=DFN
; Search by Exam
D
. S %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
. S ORD=$P(^BTPW(90621.1,2,0),U,5)
. S N="" F S N=$O(BGPG(N)) Q:N="" S DATE=$P(BGPG(N),U,1),BQIXX(DATE,ORD,N)=BGPG(N)
K BGPG
; Search by ADA
D
. S BGPC="",%=P_"^LAST ADA [BGP DENTAL EXAM ADA CODES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
. S ORD=1
. S N="" F S N=$O(BGPG(N)) Q:N="" S DATE=$P(BGPG(N),U,1),BQIXX(DATE,ORD,N)=BGPG(N)
K BGPG
; Search by CPT
D
. S BGPC=$$CPT^BGP7DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP DENTAL EXAM CPTS",0)),6)
. I BGPC="" Q
. S DATE=$P(BGPC,U,2),ORD=$P(^BTPW(90621.1,5,0),"^",5)
. S BQIXX(DATE,ORD,1)=BGPC
; Search by DX
D
. S BGPG=$$LASTDX^BGP7UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
. I BGPG="" Q
. S DATE=$P(BGPG,U,3),ORD=$P(^BTPW(90621.1,7,0),"^",5)
. S BQIXX(DATE,ORD,1)=BGPG
;
I $D(BQIXX) D
. S DATE=$O(BQIXX(""),-1),ORD=$O(BQIXX(DATE,"")),N=$O(BQIXX(DATE,ORD,""))
. S VALUE=DATE
;
Q $$FMTMDY^BQIUL1(VALUE)
;
INV ;EP
I 'FFLG S VALUE=$$FMTMDY^BQIUL1($$VISD^BQICMUTL(9000010.44,FIEN)\1)_" ("_$$GET1^DIQ(9000010.44,FIEN_",",.01,"E")_")"
I FFLG S VALUE="YES"
Q
;
GPR(CODE) ;EP
NEW BGPHOME,BQIH,BQIINDF,BQIINDG,BQIMEASF,BQIMEASG,BQIROU,BQIY,BQIYR,ERR,LIST
NEW IEN,N,VAL
D INP^BQINIGHT
D FIND^DIC(90506.1,"","","X",CODE,"","E","","","LIST","ERR")
S VAL=""
S N=0 F S N=$O(LIST("DILIST",1,N)) Q:N="" D
. I LIST("DILIST",1,N)'[BQIYR_"_" K LIST("DILIST",1,N),LIST("DILIST",2,N)
S N=0 F S N=$O(LIST("DILIST",2,N)) Q:N="" D
. S IEN=LIST("DILIST",2,N) I $P(^BQI(90506.1,IEN,0),U,3)=CODE S VAL=IEN_U_$P(^(0),U,1)
Q VAL
;
COLO(DFN) ;EP
NEW REC,CODE,IEN,NUM,DEN
S REC=$$GPR("Colorectal Cancer Screen 50-75") I REC="" Q ""
S CODE=$P(REC,U,2)
S IEN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IEN="" Q "NDA"
S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3),DEN=$P(^(0),U,4)
I DEN'=1 Q "N/A"
I DEN=1,+NUM=0 Q "NO"
Q "YES"
;
DEP(DFN) ;EP
NEW REC,CODE,IEN,NUM,DEN
S REC=$$GPR("Depression: Screening Only 18+") I REC="" Q ""
S CODE=$P(REC,U,2)
S IEN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IEN="" Q "NDA"
S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3),DEN=$P(^(0),U,4)
I DEN'=1 Q "N/A"
I DEN=1,+NUM=0 Q "NO"
Q "YES"
;
ADHD(DFN) ;EP
NEW VALUE
S VALUE=$$TAX^BQITRUTL("","BQI ADD/ADHD DXS",1,DFN,9000010.07,1,"","","","")
I 'VALUE Q "NO"
Q "YES ("_$$FMTMDY^BQIUL1($P(VALUE,U,2))_")"
;
HEAR(DFN) ;EP
NEW MS,ARRAY,CT,DATE,NBRN,NEWB,AUD,IEN,VALUE,RES
S MS=$$MEAS^BQITUTL(DFN,"HE"),CT=1
I MS S DATE=$P(MS,"^",2),ARRAY(DATE,CT)=MS_"^HEARING"
F NBRN="NEWBORN HEARING SCREEN (LEFT)","NEWBORN HEARING SCREEN (RIGHT)" D
. S NEWB=$$EXAM^BQITUTL(DFN,NBRN)
. I 'NEWB Q
. S CT=CT+1,DATE=$P(NEWB,"^",2),ARRAY(DATE,CT)=NEWB_"^"_NBRN
S AUD=$$EXAM^BQITUTL(DFN,"AUDITORY EVOKED POTENTIAL")
I AUD S CT=CT+1,DATE=$P(AUD,"^",2),ARRAY(DATE,CT)=AUD_"^"_"AUDITORY EVOKED POTENTIAL"
S DATE=$O(ARRAY(""),-1)
I DATE="" Q "NO"
S CT=$O(ARRAY(DATE,""),-1)
S IEN=$P(ARRAY(DATE,CT),"^",5),RES=$P(ARRAY(DATE,CT),"^",6)
S VALUE="YES "_$$FMTMDY^BQIUL1(DATE)_" ("_RES_")"
Q VALUE
;
VIS(DFN) ;EP - Vision
NEW VALUE,IEN,RES,DATE
S VALUE=$$EXAM^BQITUTL(DFN,"EYE EXAM - GENERAL")
I 'VALUE Q "NO"
S IEN=$P(VALUE,"^",5),RES=$$GET1^DIQ(9000010.13,IEN_",",.04,"E"),DATE=$P(VALUE,"^",2)
Q "YES "_$$FMTMDY^BQIUL1(DATE)
;Q "YES "_$$FMTMDY^BQIUL1(DATE)_" ("_RES_")"
;
WELL(DFN,NUM) ;EP - Last Number of Well Child Visits
NEW BQISBST,OK,BQSN,CNT,CDATA,CID,TXT,LIEN,VIS,CT,QTL,DATE,VALUE,ARRAY
S NUM=$G(NUM,3)
S BQISBST=$NA(^TMP("BQIWELLC",$J)) K @BQISBST
S OK=$$SUBLST^BSTSAPI(BQISBST,"PXRM BQI WELL CHILD VISIT^36^1")
S BQSN=0,CNT=0
F S BQSN=$O(@BQISBST@(BQSN)) Q:BQSN="" D
. S CDATA=@BQISBST@(BQSN)
. S CID=$P(CDATA,"^",1),TXT=$P(CDATA,"^",3)
. S BDT="",CT=0
. F S BDT=$O(^AUPNVPOV("ASNC",DFN,CID,BDT)) Q:BDT="" D
.. S LIEN=""
.. F S LIEN=$O(^AUPNVPOV("ASNC",DFN,CID,BDT,LIEN)) Q:LIEN="" D
... I $P($G(^AUPNVPOV(LIEN,11)),U,1)'=CID Q
... S VIS=$P($G(^AUPNVPOV(LIEN,0)),U,3) I VIS="" Q
... I $G(^AUPNVSIT(VIS,0))="" Q
... S CT=CT+1,DATE=9999999-BDT,ARRAY(DATE,CID,CT)=LIEN_"^"_VIS_"^"_TXT
I '$D(ARRAY) Q ""
S CT=0,QTL=0,DATE="",VALUE=""
F S DATE=$O(ARRAY(DATE),-1) Q:DATE=""!(QTL) D Q:QTL
. S CID=""
. F S CID=$O(ARRAY(DATE,CID)) Q:CID="" D
.. S VL=$O(ARRAY(DATE,CID,"")),TXT=$P(ARRAY(DATE,CID,VL),"^",3)
.. S VALUE=VALUE_$$FMTMDY^BQIUL1(DATE)_" ("_TXT_")"_$C(10)_$C(13)
.. S CT=CT+1 I CT>NUM S QTL=1
S VALUE=$$TKO^BQIUL1(VALUE,$C(10)_$C(13))
Q VALUE
;
ASQ(DFN) ;EP - Last ASQ measurement
NEW MEAS,MS,VALUE,RES,RESU,NAME
S MS="ASQ",MEAS=MS,RESU=""
F S MEAS=$O(^AUTTMSR("B",MEAS)) Q:MEAS=""!($E(MEAS,1,3)'=MS) D
. S IEN=$O(^AUTTMSR("B",MEAS,"")) I IEN="" Q
. S NAME=$P(^AUTTMSR(IEN,0),"^",2),NAME=$P(NAME,"ASQ - ",2)
. I MEAS="ASQM" S NAME="ASQ QUESTIONNAIRE (MOS)"
. S VALUE=$$MEAS^BQITUTL(DFN,MEAS)
. S RES=$P(VALUE,"^",3)
. S RESU=RESU_NAME_" "_$$FMTMDY^BQIUL1($P(VALUE,"^",2))_" ("_RES_")"_$C(10)_$C(13)
S RESU=$$TKO^BQIUL1(RESU,$C(10)_$C(13))
Q RESU
BQICMUT2 ;GDHD/HCS/ALA-Care Mgmt Utility ; 02 Nov 2016 9:53 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;;
+3 ;
MEAS(DFN,MEAS) ;EP - Last Measurement
+1 NEW VALUE,RES
+2 SET VALUE=$$MEAS^BQITUTL(DFN,MEAS)
+3 IF 'VALUE
QUIT ""
+4 SET RES=$PIECE(VALUE,"^",3)
IF MEAS="BMI"
SET RES=$JUSTIFY(RES,3,2)
+5 SET VALUE=$$FMTMDY^BQIUL1($PIECE(VALUE,"^",2))_" ("_RES_")"
+6 QUIT VALUE
+7 ;
LEAD(DFN) ;EP - Lead test
+1 NEW VALUE
+2 SET VALUE=$$LAB^BQITRUTL("",0,DFN,"BQI BLOOD LEAD TESTS","","'=","","","")
+3 IF 'VALUE
QUIT ""
+4 QUIT $PIECE(VALUE,U,2)_" ("_$PIECE(VALUE,U,3)_")"
+5 ;
INF(DFN,AGE,FFLG) ;EP - Infant Feeding record
+1 NEW VALUE,FIEN,DOB,BD1,BD2,STRT,DATE
+2 SET VALUE=""
SET FFLG=$GET(FFLG,0)
+3 IF $GET(AGE)=""
Begin DoDot:1
+4 SET FIEN=$ORDER(^AUPNVIF("AC",DFN,""),-1)
IF FIEN=""
QUIT
+5 DO INV
End DoDot:1
QUIT VALUE
+6 ;
+7 SET VALUE="NO"
+8 SET DOB=$PIECE(^DPT(DFN,0),"^",3)
+9 IF AGE="2 MOS"
SET B1=45
SET B2=89
+10 IF AGE="6 MOS"
SET B1=165
SET B2=209
+11 IF AGE="9 MOS"
SET B1=255
SET B2=299
+12 IF AGE="12 MOS"
SET B1=350
SET B2=394
+13 SET BD1=$$FMADD^XLFDT(DOB,B1)
SET BD2=$$FMADD^XLFDT(DOB,B2)
+14 SET STRT=""
+15 FOR
SET STRT=$ORDER(^AUPNVIF("AA",DFN,STRT))
IF STRT=""
QUIT
Begin DoDot:1
+16 SET DATE=9999999-STRT
+17 IF DATE'<BD1
IF DATE'>BD2
SET FIEN=$ORDER(^AUPNVIF("AA",DFN,STRT,""))
DO INV
End DoDot:1
+18 QUIT VALUE
+19 ;
DENT(DFN) ;EP - Last Dental Visit
+1 NEW VALUE,BDATE,EDATE,P,ORD,N,BGPG,BQIXX,BGPC,DATE
+2 SET VALUE=""
+3 SET BDATE=$$DATE^BQIUL1("T-60M")
SET EDATE=DT
SET P=DFN
+4 ; Search by Exam
+5 Begin DoDot:1
+6 SET %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 SET ORD=$PIECE(^BTPW(90621.1,2,0),U,5)
+8 SET N=""
FOR
SET N=$ORDER(BGPG(N))
IF N=""
QUIT
SET DATE=$PIECE(BGPG(N),U,1)
SET BQIXX(DATE,ORD,N)=BGPG(N)
End DoDot:1
+9 KILL BGPG
+10 ; Search by ADA
+11 Begin DoDot:1
+12 SET BGPC=""
SET %=P_"^LAST ADA [BGP DENTAL EXAM ADA CODES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+13 SET ORD=1
+14 SET N=""
FOR
SET N=$ORDER(BGPG(N))
IF N=""
QUIT
SET DATE=$PIECE(BGPG(N),U,1)
SET BQIXX(DATE,ORD,N)=BGPG(N)
End DoDot:1
+15 KILL BGPG
+16 ; Search by CPT
+17 Begin DoDot:1
+18 SET BGPC=$$CPT^BGP7DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP DENTAL EXAM CPTS",0)),6)
+19 IF BGPC=""
QUIT
+20 SET DATE=$PIECE(BGPC,U,2)
SET ORD=$PIECE(^BTPW(90621.1,5,0),"^",5)
+21 SET BQIXX(DATE,ORD,1)=BGPC
End DoDot:1
+22 ; Search by DX
+23 Begin DoDot:1
+24 SET BGPG=$$LASTDX^BGP7UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
+25 IF BGPG=""
QUIT
+26 SET DATE=$PIECE(BGPG,U,3)
SET ORD=$PIECE(^BTPW(90621.1,7,0),"^",5)
+27 SET BQIXX(DATE,ORD,1)=BGPG
End DoDot:1
+28 ;
+29 IF $DATA(BQIXX)
Begin DoDot:1
+30 SET DATE=$ORDER(BQIXX(""),-1)
SET ORD=$ORDER(BQIXX(DATE,""))
SET N=$ORDER(BQIXX(DATE,ORD,""))
+31 SET VALUE=DATE
End DoDot:1
+32 ;
+33 QUIT $$FMTMDY^BQIUL1(VALUE)
+34 ;
INV ;EP
+1 IF 'FFLG
SET VALUE=$$FMTMDY^BQIUL1($$VISD^BQICMUTL(9000010.44,FIEN)\1)_" ("_$$GET1^DIQ(9000010.44,FIEN_",",.01,"E")_")"
+2 IF FFLG
SET VALUE="YES"
+3 QUIT
+4 ;
GPR(CODE) ;EP
+1 NEW BGPHOME,BQIH,BQIINDF,BQIINDG,BQIMEASF,BQIMEASG,BQIROU,BQIY,BQIYR,ERR,LIST
+2 NEW IEN,N,VAL
+3 DO INP^BQINIGHT
+4 DO FIND^DIC(90506.1,"","","X",CODE,"","E","","","LIST","ERR")
+5 SET VAL=""
+6 SET N=0
FOR
SET N=$ORDER(LIST("DILIST",1,N))
IF N=""
QUIT
Begin DoDot:1
+7 IF LIST("DILIST",1,N)'[BQIYR_"_"
KILL LIST("DILIST",1,N),LIST("DILIST",2,N)
End DoDot:1
+8 SET N=0
FOR
SET N=$ORDER(LIST("DILIST",2,N))
IF N=""
QUIT
Begin DoDot:1
+9 SET IEN=LIST("DILIST",2,N)
IF $PIECE(^BQI(90506.1,IEN,0),U,3)=CODE
SET VAL=IEN_U_$PIECE(^(0),U,1)
End DoDot:1
+10 QUIT VAL
+11 ;
COLO(DFN) ;EP
+1 NEW REC,CODE,IEN,NUM,DEN
+2 SET REC=$$GPR("Colorectal Cancer Screen 50-75")
IF REC=""
QUIT ""
+3 SET CODE=$PIECE(REC,U,2)
+4 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IEN=""
QUIT "NDA"
+5 SET NUM=$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
SET DEN=$PIECE(^(0),U,4)
+6 IF DEN'=1
QUIT "N/A"
+7 IF DEN=1
IF +NUM=0
QUIT "NO"
+8 QUIT "YES"
+9 ;
DEP(DFN) ;EP
+1 NEW REC,CODE,IEN,NUM,DEN
+2 SET REC=$$GPR("Depression: Screening Only 18+")
IF REC=""
QUIT ""
+3 SET CODE=$PIECE(REC,U,2)
+4 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IEN=""
QUIT "NDA"
+5 SET NUM=$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
SET DEN=$PIECE(^(0),U,4)
+6 IF DEN'=1
QUIT "N/A"
+7 IF DEN=1
IF +NUM=0
QUIT "NO"
+8 QUIT "YES"
+9 ;
ADHD(DFN) ;EP
+1 NEW VALUE
+2 SET VALUE=$$TAX^BQITRUTL("","BQI ADD/ADHD DXS",1,DFN,9000010.07,1,"","","","")
+3 IF 'VALUE
QUIT "NO"
+4 QUIT "YES ("_$$FMTMDY^BQIUL1($PIECE(VALUE,U,2))_")"
+5 ;
HEAR(DFN) ;EP
+1 NEW MS,ARRAY,CT,DATE,NBRN,NEWB,AUD,IEN,VALUE,RES
+2 SET MS=$$MEAS^BQITUTL(DFN,"HE")
SET CT=1
+3 IF MS
SET DATE=$PIECE(MS,"^",2)
SET ARRAY(DATE,CT)=MS_"^HEARING"
+4 FOR NBRN="NEWBORN HEARING SCREEN (LEFT)","NEWBORN HEARING SCREEN (RIGHT)"
Begin DoDot:1
+5 SET NEWB=$$EXAM^BQITUTL(DFN,NBRN)
+6 IF 'NEWB
QUIT
+7 SET CT=CT+1
SET DATE=$PIECE(NEWB,"^",2)
SET ARRAY(DATE,CT)=NEWB_"^"_NBRN
End DoDot:1
+8 SET AUD=$$EXAM^BQITUTL(DFN,"AUDITORY EVOKED POTENTIAL")
+9 IF AUD
SET CT=CT+1
SET DATE=$PIECE(AUD,"^",2)
SET ARRAY(DATE,CT)=AUD_"^"_"AUDITORY EVOKED POTENTIAL"
+10 SET DATE=$ORDER(ARRAY(""),-1)
+11 IF DATE=""
QUIT "NO"
+12 SET CT=$ORDER(ARRAY(DATE,""),-1)
+13 SET IEN=$PIECE(ARRAY(DATE,CT),"^",5)
SET RES=$PIECE(ARRAY(DATE,CT),"^",6)
+14 SET VALUE="YES "_$$FMTMDY^BQIUL1(DATE)_" ("_RES_")"
+15 QUIT VALUE
+16 ;
VIS(DFN) ;EP - Vision
+1 NEW VALUE,IEN,RES,DATE
+2 SET VALUE=$$EXAM^BQITUTL(DFN,"EYE EXAM - GENERAL")
+3 IF 'VALUE
QUIT "NO"
+4 SET IEN=$PIECE(VALUE,"^",5)
SET RES=$$GET1^DIQ(9000010.13,IEN_",",.04,"E")
SET DATE=$PIECE(VALUE,"^",2)
+5 QUIT "YES "_$$FMTMDY^BQIUL1(DATE)
+6 ;Q "YES "_$$FMTMDY^BQIUL1(DATE)_" ("_RES_")"
+7 ;
WELL(DFN,NUM) ;EP - Last Number of Well Child Visits
+1 NEW BQISBST,OK,BQSN,CNT,CDATA,CID,TXT,LIEN,VIS,CT,QTL,DATE,VALUE,ARRAY
+2 SET NUM=$GET(NUM,3)
+3 SET BQISBST=$NAME(^TMP("BQIWELLC",$JOB))
KILL @BQISBST
+4 SET OK=$$SUBLST^BSTSAPI(BQISBST,"PXRM BQI WELL CHILD VISIT^36^1")
+5 SET BQSN=0
SET CNT=0
+6 FOR
SET BQSN=$ORDER(@BQISBST@(BQSN))
IF BQSN=""
QUIT
Begin DoDot:1
+7 SET CDATA=@BQISBST@(BQSN)
+8 SET CID=$PIECE(CDATA,"^",1)
SET TXT=$PIECE(CDATA,"^",3)
+9 SET BDT=""
SET CT=0
+10 FOR
SET BDT=$ORDER(^AUPNVPOV("ASNC",DFN,CID,BDT))
IF BDT=""
QUIT
Begin DoDot:2
+11 SET LIEN=""
+12 FOR
SET LIEN=$ORDER(^AUPNVPOV("ASNC",DFN,CID,BDT,LIEN))
IF LIEN=""
QUIT
Begin DoDot:3
+13 IF $PIECE($GET(^AUPNVPOV(LIEN,11)),U,1)'=CID
QUIT
+14 SET VIS=$PIECE($GET(^AUPNVPOV(LIEN,0)),U,3)
IF VIS=""
QUIT
+15 IF $GET(^AUPNVSIT(VIS,0))=""
QUIT
+16 SET CT=CT+1
SET DATE=9999999-BDT
SET ARRAY(DATE,CID,CT)=LIEN_"^"_VIS_"^"_TXT
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF '$DATA(ARRAY)
QUIT ""
+18 SET CT=0
SET QTL=0
SET DATE=""
SET VALUE=""
+19 FOR
SET DATE=$ORDER(ARRAY(DATE),-1)
IF DATE=""!(QTL)
QUIT
Begin DoDot:1
+20 SET CID=""
+21 FOR
SET CID=$ORDER(ARRAY(DATE,CID))
IF CID=""
QUIT
Begin DoDot:2
+22 SET VL=$ORDER(ARRAY(DATE,CID,""))
SET TXT=$PIECE(ARRAY(DATE,CID,VL),"^",3)
+23 SET VALUE=VALUE_$$FMTMDY^BQIUL1(DATE)_" ("_TXT_")"_$CHAR(10)_$CHAR(13)
+24 SET CT=CT+1
IF CT>NUM
SET QTL=1
End DoDot:2
End DoDot:1
IF QTL
QUIT
+25 SET VALUE=$$TKO^BQIUL1(VALUE,$CHAR(10)_$CHAR(13))
+26 QUIT VALUE
+27 ;
ASQ(DFN) ;EP - Last ASQ measurement
+1 NEW MEAS,MS,VALUE,RES,RESU,NAME
+2 SET MS="ASQ"
SET MEAS=MS
SET RESU=""
+3 FOR
SET MEAS=$ORDER(^AUTTMSR("B",MEAS))
IF MEAS=""!($EXTRACT(MEAS,1,3)'=MS)
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^AUTTMSR("B",MEAS,""))
IF IEN=""
QUIT
+5 SET NAME=$PIECE(^AUTTMSR(IEN,0),"^",2)
SET NAME=$PIECE(NAME,"ASQ - ",2)
+6 IF MEAS="ASQM"
SET NAME="ASQ QUESTIONNAIRE (MOS)"
+7 SET VALUE=$$MEAS^BQITUTL(DFN,MEAS)
+8 SET RES=$PIECE(VALUE,"^",3)
+9 SET RESU=RESU_NAME_" "_$$FMTMDY^BQIUL1($PIECE(VALUE,"^",2))_" ("_RES_")"_$CHAR(10)_$CHAR(13)
End DoDot:1
+10 SET RESU=$$TKO^BQIUL1(RESU,$CHAR(10)_$CHAR(13))
+11 QUIT RESU
