- 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
