APCLSILU ; IHS/CMI/LAB - utilities for ili/h1n1 ; 13 Aug 2014 3:00 PM
;;3.0;IHS PCC REPORTS;**24,26,27,29,30**;FEB 05, 1997;Build 27
;----------
ICD(VAL,TAXIEN,TYP) ;EP -- check to see if value is in taxonomy in ^TMP("BDMTMP",$J,Taxonomy Name
;add 3rd param with pass type
;WILL ALWAYS BE ATXAX, NOT LAB
NEW TAXNM
S TAXNM=$P($G(^ATXAX(TAXIEN,0)),U,1)
I TAXNM="" Q $$ICD^ATXCHK(VAL,TAXIEN,TYP)
I '$D(^XTMP("APCLILITAX",$J,TAXNM)) Q $$ICD^ATXCHK(VAL,$O(^ATXAX("B",TAXNM,0)),TYP)
I $D(^XTMP("APCLILITAX",$J,TAXNM,VAL)) Q 1
Q 0
;
ICDDX(C,D,I) ;PEP - CHECK FOR ICD10
I $T(ICDDX^ICDEX)]"" Q $$ICDDX^ICDEX(C,$G(D),,$G(I))
Q $$ICDDX^ICDCODE(C,$G(D))
;
ICDOP(C,D,I) ;PEP - CHECK FOR ICD10
I $G(I)="" S I="I"
I $T(ICDOP^ICDEX)]"" Q $$ICDOP^ICDEX(C,$G(D),,I)
Q $$ICDOP^ICDCODE(C,$G(D))
;
VSTD(C,D) ;EP - CHECK FOR ICD10
I $T(VSTD^ICDEX)]"" Q $$VSTD^ICDEX(C,$G(D))
Q $$VSTD^ICDCODE(C,$G(D))
;
VSTP(C,D) ;EP - CHECK FOR ICD10
I $T(VSTP^ICDEX)]"" Q $$VSTP^ICDEX(C,$G(D))
Q $$VSTP^ICDCODE(C,$G(D))
;
ICDD(C,A,D) ;EP - CHECK FOR ICD10
I $T(ICDD^ICDEX)]"" Q $$ICDD^ICDEX(C,A,$G(D))
Q $$ICDD^ICDCODE(C,A,$G(D))
DOB(DFN) ;EP
;---> Return Patient's Date of APCLrth in Fileman format.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "NO PATIENT"
Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
Q $P(^DPT(DFN,0),U,3)
;
;
;
;----------
AGE(DFN,APCLZ,APCLDT) ;EP
;---> Return Patient's Age.
;---> Parameters:
; 1 - DFN (req) IEN in PATIENT File.
; 2 - APCLZ (opt) APCLZ=1,2,3 1=years, 2=months, 3=days.
; 2 will be assumed if not passed.
; 3 - APCLDT (opt) Date on which Age should be calculated.
;
N APCLDOB,X,X1,X2,D,E S:$G(APCLZ)="" APCLZ=2
Q:'$G(DFN) ""
S APCLDOB=$$DOB(DFN)
Q:'APCLDOB ""
S:'$G(DT) DT=$$DT^XLFDT
S:'$G(APCLDT) APCLDT=DT
Q:APCLDT<APCLDOB ""
;
;---> Age in Years.
N APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
S APCLM1=$E(APCLDOB,4,7),APCLM2=$E(APCLDT,4,7)
S APCLY1=$E(APCLDOB,1,3),APCLY2=$E(APCLDT,1,3)
S APCLAGEY=APCLY2-APCLY1 S:APCLM2<APCLM1 APCLAGEY=APCLAGEY-1
S:APCLAGEY<1 APCLAGEY="<1"
Q:APCLZ=1 APCLAGEY
;
;---> Age in Months.
S APCLD1=$E(APCLM1,3,4),APCLM1=$E(APCLM1,1,2)
S APCLD2=$E(APCLM2,3,4),APCLM2=$E(APCLM2,1,2)
S APCLAGEM=12*APCLAGEY
I APCLM2=APCLM1&(APCLD2<APCLD1) S APCLAGEM=APCLAGEM+12
I APCLM2>APCLM1 S APCLAGEM=APCLAGEM+APCLM2-APCLM1
I APCLM2<APCLM1 S APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
S:APCLD2<APCLD1 APCLAGEM=APCLAGEM-1
Q:APCLZ=2 APCLAGEM
;
;---> Age in Days.
S X1=APCLDT,X2=APCLDOB
D ^%DTC
Q X
;
;
;----------
AGEF(DFN,APCLDT) ;EP
;---> Age formatted "35 Months" or "23 Years"
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - APCLDT (opt) Date on which Age should be calculated.
;
N Y
S Y=$$AGE(DFN,2,$G(APCLDT))
Q:Y["DECEASED" Y
Q:Y["NOT BORN" Y
;
;---> If over 60 months, return years.
I Y>60 S Y=$$AGE(DFN,1,$G(APCLDT)) Q Y_$S(Y=1:"year",1:" yrs")
;
;---> If under 1 month return days.
I Y<1 S Y=$$AGE(DFN,3,$G(APCLDT)) Q Y_$S(Y=1:" day",1:" days")
;
;---> Return months
Q Y_$S(Y=1:" mth",1:" mths")
;
;
;----------
DECEASED(DFN,APCLDT) ;EP
;---> Return 1 if patient is deceased, 0 if not deceased.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
;
Q:'$G(DFN) 0
N X S X=+$G(^DPT(DFN,.35))
Q:'X 0
Q:'$G(APCLDT) 1
Q X
;
;
UNFOLDTX ;EP -- unfold all taxes for ili export into ^TMP("APCLILITAX",$J,Taxonomy Name
;lets go through all the taxonomies needed here and put them in above location
K ^XTMP("APCLILITAX",$J)
I '$D(^ICDS(0)) Q ;icd10 isn't there so don't bother
NEW APCLDA,APCLTAX,APCLFL,APCLTAXI,APCLVAL,APCLTYP,APCLTGT
S APCLDA=0 F S APCLDA=$O(^APCLILIT(APCLDA)) Q:'APCLDA D
. S APCLTAX=$P($G(^APCLILIT(APCLDA,0)),U)
. S APCLFL=$P($G(^APCLILIT(APCLDA,0)),U,2)
. S APCLTYP=$S(APCLFL=60:"L",1:"")
. S APCLTAXI=$O(^ATXAX("B",APCLTAX,0))
. I APCLTYP="L" D
.. S APCLTAXI=$O(^ATXLAB("B",APCLTAX,0))
. S APCLTGT="^XTMP("_"""APCLILITAX"""_","_$J_","_""""_APCLTAX_""""_")"
. D BLDTAX^ATXAPI(APCLTAX,APCLTGT,APCLTAXI,APCLTYP)
Q
COMM ;EP
K ^APCLDATA($J)
NEW APCLX,APCLC,APCLCNT,APCLASUF,XBGL,XBFN,XBF,XBE,XBFLT,XBMED,XBCON,XBS1,XBQ,APCLDBID,C,APCLI
;export community taxonomy
S APCLDBID=$P(^AUTTSITE(1,0),U,1)
S APCLDBID=$$VAL^XBDIQ1(9999999.06,APCLDBID,.32)
S APCLX=0,APCLCNT=0 F S APCLX=$O(^BGPSITE(APCLX)) Q:APCLX'=+APCLX D
.S APCLC=$P($G(^BGPSITE(APCLX,0)),U,5)
.Q:APCLC=""
.S APCLASUF=$P($G(^AUTTLOC(APCLX,0)),U,10)
.Q:APCLASUF=""
.;K ^TMP($J,"COMM")
.S APCLI=0 F S APCLI=$O(^ATXAX(APCLC,21,APCLI)) Q:APCLI'=+APCLI D
..S C=$P($G(^ATXAX(APCLC,21,APCLI,0)),U,1)
..S C=$O(^AUTTCOM("B",C,0))
..I 'C Q
..S APCLCNT=APCLCNT+1
..S ^APCLDATA($J,APCLCNT)=APCLDBID_U_APCLASUF_U_$P(^AUTTCOM(C,0),U,8)_U_$P(^AUTTCOM(C,0),U,1)
.NEW TST
.S TST=0
.;I '$$PROD^XUPROD() S TST=1
.I $P($G(^APCLILIC(1,0)),U,5)="T" S TST=1
.S XBFN="COMM"_$S(TST:"Z",1:"F")_"_"_APCLASUF_"_"_$$DATE^APCLSILI(APCLZHSD)_".txt"
.S XBGL="APCLDATA",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
.S XBCON=1
.S XBS1="SURVEILLANCE ILI SEND"
.S XBQ="N"
.D ^XBGSAVE
.K ^APCLDATA($J)
Q
INSTALLD(APCLSTAL) ;EP - Determine if patch APCLSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW APCLY,DIC,X,Y
S X=$P(APCLSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",22,",X=$P(APCLSTAL,"*",2)
D ^DIC
I Y<1 Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(APCLSTAL,"*",3)
D ^DIC
S APCLY=Y
Q $S(APCLY<1:0,1:1)
LASTPRCT(P,BD,ED,T,F) ;EP
I '$G(P) Q ""
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
I $G(F)="" S F="D"
S T=$G(T)
NEW A,B,C,D,E,TIEN,R,I
S TIEN="" I T]"" S TIEN=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I TIEN="" Q ""
S R="" ;return value
S B=9999999-BD,E=9999999-ED ;get inverse date and begin at edate-1 and end when greater than begin date
S D=E-1 F S D=$O(^AUPNVPRC("AA",P,D)) Q:D=""!(D>B)!(R]"") D
.S I=0 F S I=$O(^AUPNVPRC("AA",P,D,I)) Q:I'=+I!(R]"") D
..S C=$P($G(^AUPNVPRC(I,0)),U)
..Q:C="" ;bad xref
..Q:'$D(^ICD0(C))
..I TIEN Q:'$$ICD^ATXAPI(C,TIEN,0)
..S R=(9999999-D)_"^PROC: "_$P($$ICDOP(C,(9999999-D),"I"),U,2)_"^"_$$VAL^XBDIQ1(9000010.08,I,.04)_"^"_$P(^AUPNVPRC(I,0),U,3)_"^9000010.08^"_I
..Q
.Q
I R="" Q ""
I F="D" Q $P(R,U)
Q R
APCLSILU ; IHS/CMI/LAB - utilities for ili/h1n1 ; 13 Aug 2014 3:00 PM
+1 ;;3.0;IHS PCC REPORTS;**24,26,27,29,30**;FEB 05, 1997;Build 27
+2 ;----------
ICD(VAL,TAXIEN,TYP) ;EP -- check to see if value is in taxonomy in ^TMP("BDMTMP",$J,Taxonomy Name
+1 ;add 3rd param with pass type
+2 ;WILL ALWAYS BE ATXAX, NOT LAB
+3 NEW TAXNM
+4 SET TAXNM=$PIECE($GET(^ATXAX(TAXIEN,0)),U,1)
+5 IF TAXNM=""
QUIT $$ICD^ATXCHK(VAL,TAXIEN,TYP)
+6 IF '$DATA(^XTMP("APCLILITAX",$JOB,TAXNM))
QUIT $$ICD^ATXCHK(VAL,$ORDER(^ATXAX("B",TAXNM,0)),TYP)
+7 IF $DATA(^XTMP("APCLILITAX",$JOB,TAXNM,VAL))
QUIT 1
+8 QUIT 0
+9 ;
ICDDX(C,D,I) ;PEP - CHECK FOR ICD10
+1 IF $TEXT(ICDDX^ICDEX)]""
QUIT $$ICDDX^ICDEX(C,$GET(D),,$GET(I))
+2 QUIT $$ICDDX^ICDCODE(C,$GET(D))
+3 ;
ICDOP(C,D,I) ;PEP - CHECK FOR ICD10
+1 IF $GET(I)=""
SET I="I"
+2 IF $TEXT(ICDOP^ICDEX)]""
QUIT $$ICDOP^ICDEX(C,$GET(D),,I)
+3 QUIT $$ICDOP^ICDCODE(C,$GET(D))
+4 ;
VSTD(C,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(VSTD^ICDEX)]""
QUIT $$VSTD^ICDEX(C,$GET(D))
+2 QUIT $$VSTD^ICDCODE(C,$GET(D))
+3 ;
VSTP(C,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(VSTP^ICDEX)]""
QUIT $$VSTP^ICDEX(C,$GET(D))
+2 QUIT $$VSTP^ICDCODE(C,$GET(D))
+3 ;
ICDD(C,A,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(ICDD^ICDEX)]""
QUIT $$ICDD^ICDEX(C,A,$GET(D))
+2 QUIT $$ICDD^ICDCODE(C,A,$GET(D))
DOB(DFN) ;EP
+1 ;---> Return Patient's Date of APCLrth in Fileman format.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$PIECE($GET(^DPT(DFN,0)),U,3)
QUIT "NOT ENTERED"
+7 QUIT $PIECE(^DPT(DFN,0),U,3)
+8 ;
+9 ;
+10 ;
+11 ;----------
AGE(DFN,APCLZ,APCLDT) ;EP
+1 ;---> Return Patient's Age.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) IEN in PATIENT File.
+4 ; 2 - APCLZ (opt) APCLZ=1,2,3 1=years, 2=months, 3=days.
+5 ; 2 will be assumed if not passed.
+6 ; 3 - APCLDT (opt) Date on which Age should be calculated.
+7 ;
+8 NEW APCLDOB,X,X1,X2,D,E
IF $GET(APCLZ)=""
SET APCLZ=2
+9 IF '$GET(DFN)
QUIT ""
+10 SET APCLDOB=$$DOB(DFN)
+11 IF 'APCLDOB
QUIT ""
+12 IF '$GET(DT)
SET DT=$$DT^XLFDT
+13 IF '$GET(APCLDT)
SET APCLDT=DT
+14 IF APCLDT<APCLDOB
QUIT ""
+15 ;
+16 ;---> Age in Years.
+17 NEW APCLAGEY,APCLAGEM,APCLD1,APCLD2,APCLM1,APCLM2,APCLY1,APCLY2
+18 SET APCLM1=$EXTRACT(APCLDOB,4,7)
SET APCLM2=$EXTRACT(APCLDT,4,7)
+19 SET APCLY1=$EXTRACT(APCLDOB,1,3)
SET APCLY2=$EXTRACT(APCLDT,1,3)
+20 SET APCLAGEY=APCLY2-APCLY1
IF APCLM2<APCLM1
SET APCLAGEY=APCLAGEY-1
+21 IF APCLAGEY<1
SET APCLAGEY="<1"
+22 IF APCLZ=1
QUIT APCLAGEY
+23 ;
+24 ;---> Age in Months.
+25 SET APCLD1=$EXTRACT(APCLM1,3,4)
SET APCLM1=$EXTRACT(APCLM1,1,2)
+26 SET APCLD2=$EXTRACT(APCLM2,3,4)
SET APCLM2=$EXTRACT(APCLM2,1,2)
+27 SET APCLAGEM=12*APCLAGEY
+28 IF APCLM2=APCLM1&(APCLD2<APCLD1)
SET APCLAGEM=APCLAGEM+12
+29 IF APCLM2>APCLM1
SET APCLAGEM=APCLAGEM+APCLM2-APCLM1
+30 IF APCLM2<APCLM1
SET APCLAGEM=APCLAGEM+APCLM2+(12-APCLM1)
+31 IF APCLD2<APCLD1
SET APCLAGEM=APCLAGEM-1
+32 IF APCLZ=2
QUIT APCLAGEM
+33 ;
+34 ;---> Age in Days.
+35 SET X1=APCLDT
SET X2=APCLDOB
+36 DO ^%DTC
+37 QUIT X
+38 ;
+39 ;
+40 ;----------
AGEF(DFN,APCLDT) ;EP
+1 ;---> Age formatted "35 Months" or "23 Years"
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - APCLDT (opt) Date on which Age should be calculated.
+5 ;
+6 NEW Y
+7 SET Y=$$AGE(DFN,2,$GET(APCLDT))
+8 IF Y["DECEASED"
QUIT Y
+9 IF Y["NOT BORN"
QUIT Y
+10 ;
+11 ;---> If over 60 months, return years.
+12 IF Y>60
SET Y=$$AGE(DFN,1,$GET(APCLDT))
QUIT Y_$SELECT(Y=1:"year",1:" yrs")
+13 ;
+14 ;---> If under 1 month return days.
+15 IF Y<1
SET Y=$$AGE(DFN,3,$GET(APCLDT))
QUIT Y_$SELECT(Y=1:" day",1:" days")
+16 ;
+17 ;---> Return months
+18 QUIT Y_$SELECT(Y=1:" mth",1:" mths")
+19 ;
+20 ;
+21 ;----------
DECEASED(DFN,APCLDT) ;EP
+1 ;---> Return 1 if patient is deceased, 0 if not deceased.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - APCLDT (opt) If APCLDT=1 return Date of Death (Fileman format).
+5 ;
+6 IF '$GET(DFN)
QUIT 0
+7 NEW X
SET X=+$GET(^DPT(DFN,.35))
+8 IF 'X
QUIT 0
+9 IF '$GET(APCLDT)
QUIT 1
+10 QUIT X
+11 ;
+12 ;
UNFOLDTX ;EP -- unfold all taxes for ili export into ^TMP("APCLILITAX",$J,Taxonomy Name
+1 ;lets go through all the taxonomies needed here and put them in above location
+2 KILL ^XTMP("APCLILITAX",$JOB)
+3 ;icd10 isn't there so don't bother
IF '$DATA(^ICDS(0))
QUIT
+4 NEW APCLDA,APCLTAX,APCLFL,APCLTAXI,APCLVAL,APCLTYP,APCLTGT
+5 SET APCLDA=0
FOR
SET APCLDA=$ORDER(^APCLILIT(APCLDA))
IF 'APCLDA
QUIT
Begin DoDot:1
+6 SET APCLTAX=$PIECE($GET(^APCLILIT(APCLDA,0)),U)
+7 SET APCLFL=$PIECE($GET(^APCLILIT(APCLDA,0)),U,2)
+8 SET APCLTYP=$SELECT(APCLFL=60:"L",1:"")
+9 SET APCLTAXI=$ORDER(^ATXAX("B",APCLTAX,0))
+10 IF APCLTYP="L"
Begin DoDot:2
+11 SET APCLTAXI=$ORDER(^ATXLAB("B",APCLTAX,0))
End DoDot:2
+12 SET APCLTGT="^XTMP("_"""APCLILITAX"""_","_$JOB_","_""""_APCLTAX_""""_")"
+13 DO BLDTAX^ATXAPI(APCLTAX,APCLTGT,APCLTAXI,APCLTYP)
End DoDot:1
+14 QUIT
COMM ;EP
+1 KILL ^APCLDATA($JOB)
+2 NEW APCLX,APCLC,APCLCNT,APCLASUF,XBGL,XBFN,XBF,XBE,XBFLT,XBMED,XBCON,XBS1,XBQ,APCLDBID,C,APCLI
+3 ;export community taxonomy
+4 SET APCLDBID=$PIECE(^AUTTSITE(1,0),U,1)
+5 SET APCLDBID=$$VAL^XBDIQ1(9999999.06,APCLDBID,.32)
+6 SET APCLX=0
SET APCLCNT=0
FOR
SET APCLX=$ORDER(^BGPSITE(APCLX))
IF APCLX'=+APCLX
QUIT
Begin DoDot:1
+7 SET APCLC=$PIECE($GET(^BGPSITE(APCLX,0)),U,5)
+8 IF APCLC=""
QUIT
+9 SET APCLASUF=$PIECE($GET(^AUTTLOC(APCLX,0)),U,10)
+10 IF APCLASUF=""
QUIT
+11 ;K ^TMP($J,"COMM")
+12 SET APCLI=0
FOR
SET APCLI=$ORDER(^ATXAX(APCLC,21,APCLI))
IF APCLI'=+APCLI
QUIT
Begin DoDot:2
+13 SET C=$PIECE($GET(^ATXAX(APCLC,21,APCLI,0)),U,1)
+14 SET C=$ORDER(^AUTTCOM("B",C,0))
+15 IF 'C
QUIT
+16 SET APCLCNT=APCLCNT+1
+17 SET ^APCLDATA($JOB,APCLCNT)=APCLDBID_U_APCLASUF_U_$PIECE(^AUTTCOM(C,0),U,8)_U_$PIECE(^AUTTCOM(C,0),U,1)
End DoDot:2
+18 NEW TST
+19 SET TST=0
+20 ;I '$$PROD^XUPROD() S TST=1
+21 IF $PIECE($GET(^APCLILIC(1,0)),U,5)="T"
SET TST=1
+22 SET XBFN="COMM"_$SELECT(TST:"Z",1:"F")_"_"_APCLASUF_"_"_$$DATE^APCLSILI(APCLZHSD)_".txt"
+23 SET XBGL="APCLDATA"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+24 SET XBCON=1
+25 SET XBS1="SURVEILLANCE ILI SEND"
+26 SET XBQ="N"
+27 DO ^XBGSAVE
+28 KILL ^APCLDATA($JOB)
End DoDot:1
+29 QUIT
INSTALLD(APCLSTAL) ;EP - Determine if patch APCLSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW APCLY,DIC,X,Y
+4 SET X=$PIECE(APCLSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(APCLSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(APCLSTAL,"*",3)
+12 DO ^DIC
+13 SET APCLY=Y
+14 QUIT $SELECT(APCLY<1:0,1:1)
LASTPRCT(P,BD,ED,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+3 IF $GET(ED)=""
SET ED=DT
+4 IF $GET(F)=""
SET F="D"
+5 SET T=$GET(T)
+6 NEW A,B,C,D,E,TIEN,R,I
+7 ;get taxonomy ien
SET TIEN=""
IF T]""
SET TIEN=$ORDER(^ATXAX("B",T,0))
+8 IF TIEN=""
QUIT ""
+9 ;return value
SET R=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET E=9999999-ED
+11 SET D=E-1
FOR
SET D=$ORDER(^AUPNVPRC("AA",P,D))
IF D=""!(D>B)!(R]"")
QUIT
Begin DoDot:1
+12 SET I=0
FOR
SET I=$ORDER(^AUPNVPRC("AA",P,D,I))
IF I'=+I!(R]"")
QUIT
Begin DoDot:2
+13 SET C=$PIECE($GET(^AUPNVPRC(I,0)),U)
+14 ;bad xref
IF C=""
QUIT
+15 IF '$DATA(^ICD0(C))
QUIT
+16 IF TIEN
IF '$$ICD^ATXAPI(C,TIEN,0)
QUIT
+17 SET R=(9999999-D)_"^PROC: "_$PIECE($$ICDOP(C,(9999999-D),"I"),U,2)_"^"_$$VAL^XBDIQ1(9000010.08,I,.04)_"^"_$PIECE(^AUPNVPRC(I,0),U,3)_"^9000010.08^"_I
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF R=""
QUIT ""
+21 IF F="D"
QUIT $PIECE(R,U)
+22 QUIT R
