BGP8UTL2 ; IHS/CMI/LAB - UTILITIES 06 Jan 2017 9:49 AM ; 08 Jan 2018 7:50 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
CODEN(X,F) ;EP - GET CODE
I $D(^ICDS(0)) Q $$CODEN^ICDEX(X,F)
Q $$CODEN^ICDCODE(X,F)
;
ICD(VAL,TAXIEN,TYP) ;EP - CHECK TAX
;add 3rd param with pass type
;WILL ALWAYS BE ATXAX, NOT LAB
I $G(VAL)="" Q 0
NEW TAXNM
S TAXNM=$P($G(^ATXAX(TAXIEN,0)),U,1)
I TAXNM="" Q $$ICD^ATXCHK(VAL,TAXIEN,TYP)
I '$D(^XTMP("BGP15TAX",$J,TAXNM)) Q $$ICD^ATXCHK(VAL,TAXIEN,TYP)
I $D(^XTMP("BGP15TAX",$J,TAXNM,VAL)) Q 1
;Q $$ICD^ATXCHK(VAL,TAXIEN,TYPE)
Q 0
;
;
ICDDX(C,D,I) ;EP - GET CODE
I $D(^ICDS(0)) Q $$ICDDX^ICDEX(C,$G(D))
Q $$ICDDX^ICDCODE(C,$G(D),$G(I))
;
ICDOP(C,D,I) ;EP - GET CODE
I $G(I)="" S I="I"
I $D(^ICDS(0)) Q $$ICDOP^ICDEX(C,$G(D),,I)
Q $$ICDOP^ICDCODE(C,$G(D))
;
VSTD(C,D) ;EP
I $D(^ICDS(0)) Q $$VSTD^ICDEX(C,$G(D))
Q $$VSTD^ICDCODE(C,$G(D))
;
VSTP(C,D) ;EP
I $D(^ICDS(0)) Q $$VSTP^ICDEX(C,$G(D))
Q $$VSTP^ICDCODE(C,$G(D))
;
ICDD(C,A,D) ;EP
I $D(^ICDS(0)) Q $$ICDD^ICDEX(C,A,$G(D))
Q $$ICDD^ICDCODE(C,A,$G(D))
EDD(P,BDATE,EDATE) ;EP - find EDD
NEW EDD,X,Y,Z,D,W,D,A
S EDD=""
;first check bjpn prenatal file
S Z=$$FMADD^XLFDT(EDATE,243)
S X=0 F S X=$O(^BJPNPL("D",P,X)) Q:X'=+X D
.S Y=$$GET1^DIQ(90680.01,X,.09,"I")
.Q:Y<BDATE
.Q:Y>Z
.I Y>EDD S EDD=Y
I EDD Q EDD
;NEXT CHECK EDD IN 9000017
S Y=$P($G(^AUPNREP(P,13)),U,11)
I Y>EDD S EDD=Y
I EDD Q EDD
;FIND LAST RECORDED EGA VALUE
S Y=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","EGA")
I Y D I EDD Q EDD
.S Z=$P(Y,U,2),R=$P(Y,U,4)
.S W=$P(R," ",1)
.S D=+$P($P(R," ",2),"/")
.S A=(W*7)+D
.S A=280-A
.S EDD=$$FMADD^XLFDT(Z,A)
.I EDD'>BDATE S EDD=""
Q EDD
;
GETDIR() ;EP - get default directory
NEW D
S D=""
S D=$P($G(^BGPSITE(DUZ(2),0)),U,14)
I D]"" Q D
S D=$P($G(^AUTTSITE(1,1)),"^",2)
I D]"" Q D
S D=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
I D]"" Q D
I $P(^AUTTSITE(1,0),U,21)=1 S D="/usr/spool/uucppublic/"
Q D
GETDEDIR() ;EP - get default directory
NEW D
S D=""
S D=$P($G(^AUTTSITE(1,1)),"^",2)
I D]"" Q D
S D=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
I D]"" Q D
I $P(^AUTTSITE(1,0),U,21)=1 S D="/usr/spool/uucppublic/"
Q D
DIRCHK ;EP - CALLED FROM INPUT TX ON SITE PARAMETER
NEW BGPX,BGPL,BGPHOLDX
S BGPHOLDX=X
S BGPX=$$LIST^%ZISH(X,"*.*",.BGPL)
I BGPX D EN^DDIOL("Not a valid directory!") K X,BGPX,BGPY Q
S X=BGPHOLDX
K BGPL,BGPX
Q
;
GETMEDS(P,BGPMBD,BGPMED,TAXM,TAXN,TAXC,BGPDNAME,BGPZ,TAXRXN) ;EP
S TAXM=$G(TAXM)
S TAXN=$G(TAXN)
S TAXC=$G(TAXC)
S TAXRXN=$G(TAXRXN)
K ^TMP($J,"MEDS"),BGPZ
S BGPDNAME=$G(BGPDNAME)
NEW BGPC1,BGPINED,BGPINBD,BGPMIEN,BGPD,X,Y,T,T1,D,G,T2,T3
S BGPC1=0 K BGPZ
S BGPINED=(9999999-BGPMED)-1,BGPINBD=(9999999-BGPMBD)
F S BGPINED=$O(^AUPNVMED("AA",P,BGPINED)) Q:BGPINED=""!(BGPINED>BGPINBD) D
.S BGPMIEN=0 F S BGPMIEN=$O(^AUPNVMED("AA",P,BGPINED,BGPMIEN)) Q:BGPMIEN'=+BGPMIEN D
..Q:'$D(^AUPNVMED(BGPMIEN,0))
..S BGPD=$P(^AUPNVMED(BGPMIEN,0),U)
..Q:BGPD=""
..Q:'$D(^PSDRUG(BGPD,0))
..S BGPC1=BGPC1+1
..S ^TMP($J,"MEDS","ORDER",(9999999-BGPINED),BGPC1)=(9999999-BGPINED)_U_$P(^PSDRUG(BGPD,0),U)_U_$P(^PSDRUG(BGPD,0),U)_U_BGPMIEN_U_$P(^AUPNVMED(BGPMIEN,0),U,3)
;reorder
S BGPC1=0,X=0
F S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X D
.S Y=0 F S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y D
..S BGPC1=BGPC1+1
..S ^TMP($J,"MEDS",BGPC1)=^TMP($J,"MEDS","ORDER",X,Y)
K ^TMP($J,"MEDS","ORDER")
S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0)) I T="" W BGPBOMB
S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0)) I T1="" W BGPBOMB
S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
S T3="" I TAXRXN]"" S T3=$O(^ATXAX("B",TAXRXN,0))
S BGPC1=0,X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
.S C=$P($G(^PSDRUG(D,2)),U,4)
.I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
.I T,$D(^ATXAX(T,21,"B",D)) S G=1
.I BGPDNAME]"",$P(^PSDRUG(D,0),U)[BGPDNAME S G=1
.S C=$$VAL^XBDIQ1(9000010.14,Y,9999999.27)
.I C]"",T3,$D(^ATXAX(T3,21,"B",C)) S G=1
.I TAXM="",TAXN="",TAXC="",TAXRXN="" S G=1 ;WANTS ALL MEDS
.I G=1 S BGPC1=BGPC1+1,BGPZ(BGPC1)=^TMP($J,"MEDS",X)
.Q
K ^TMP($J,"MEDS")
K BGPINED,BGPINBD,BGPMBD,BGPMED,BGPD,BGPC1,BGPDNAME
Q
RCIS(P,BDATE,EDATE,ICDC,CPTC) ;EP
I '$G(P) Q ""
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
I $G(EDATE)="" S EDATE=DT
S ICDC=$G(ICDC)
S CPTC=$G(CPTC)
;find a referral in date range BDATE to EDATE
NEW ICDCAT,CPTCAT,X,Y,D,A,B,G
F X=1:1 S Y=$P(ICDC,";",X) Q:Y="" S Y=$O(^BMCTDXC("B",Y,0)) I Y S ICDCAT(Y)=""
F X=1:1 S Y=$P(CPTC,";",X) Q:Y="" S Y=$O(^BMCTSVC("B",Y,0)) I Y S CPTCAT(Y)=""
S X=0,G="" F S X=$O(^BMCREF("D",P,X)) Q:X'=+X!(G) D
.Q:'$D(^BMCREF(X,0)) ;bad xref
.S D=$P(^BMCREF(X,0),U,1),D=$P(D,".")
.Q:D<BDATE ;before date range
.Q:D>EDATE ;after end date
.S Y=$P(^BMCREF(X,0),U,12)
.I $D(ICDCAT),Y="" Q ;want certain categories and this one blank
.I $D(ICDCAT),'$D(ICDCAT(Y)) Q ;want certain categories and this one doesn't match
.S Y=$P(^BMCREF(X,0),U,13)
.I $D(CPTCAT),Y="" Q ;want certain categories and this one blank
.I $D(CPTCAT),'$D(CPTCAT(Y)) Q ;want certain categories and this one doesn't match
.S G=X
I 'G Q ""
S X="" F Y=.07,.08,.09 S A=$$VAL^XBDIQ1(90001,G,Y) I A]"" S:X]"" X=X_"; "
Q 1_"^"_$P($P(^BMCREF(G,0),U),".")_"^"_$$DATE^BGP8UTL($P($P(^BMCREF(G,0),U),"."))_"^"_"RCIS referral"_"^"_X_"^"_"90001"_"^"_G
;
CHKDST() ;EP - check the demo patient search template to see if it is complete
;return a 1 if template is okay
;return a 0^message if it isn't
;if it isn't the caller should ask the user if they want to continue
NEW X
S X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
I 'X Q "0^RPMS DEMO PATIENT NAMES Search Template does not exist"
I '$O(^DIBT(X,1,0)) Q "0^RPMS DEMO PATIENT NAMES Search Template has no entries"
Q 1
DSTCONT() ;EP - called to ask user if they want to continue
NEW DIR,X,Y,DIRUT
W !!,"Your ",$P(BGPDPST,U,2),".",!,"If you have 'DEMO' patients whose names begin with something"
W !,"other than 'DEMO,PATIENT' they will not be excluded from this report"
W !,"unless you update this template.",!
S DIR(0)="Y",DIR("A")="Do you wish to continue to generate this report",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q 0
I 'Y Q 0
Q 1
DEMOCHK() ;EP - called to check demo patient
NEW BGPDPST
S BGPDPST=$$CHKDST()
I BGPDPST Q 1 ;no action, demo template is okay
S BGPDPST=$$DSTCONT()
Q BGPDPST
;
UNFOLDTX ;EP
K ^XTMP("BGP15TAX",$J)
;lets go through all the taxonomies needed here and put them in above location
I '$D(^ICDS(0)) G SNOMED ;icd10 isn't there so don't bother
NEW BGPDA,BGPTAX,BGPFL,BGPTAXI,BGPVAL,BGPTYP,BGPTGT,OUT,N
S BGPDA=0 F S BGPDA=$O(^BGPTAXR(BGPDA)) Q:'BGPDA D
. S BGPTAX=$P($G(^BGPTAXR(BGPDA,0)),U)
. S BGPFL=$P($G(^BGPTAXR(BGPDA,0)),U,2)
. I BGPFL'="C",BGPFL'="D",BGPFL'="P" Q ;only dx, proc, cpt for now
. S BGPTYP=""
. S BGPTAXI=$O(^ATXAX("B",BGPTAX,0))
. I BGPTYP="L" D
.. S BGPTAXI=$O(^ATXLAB("B",BGPTAX,0))
. S BGPTGT="^XTMP("_"""BGP15TAX"""_","_$J_","_""""_BGPTAX_""""_")"
. D BLDTAX^ATXAPI(BGPTAX,BGPTGT,BGPTAXI,BGPTYP)
S ^XTMP("BGP15TAX",0)=$$FMADD^XLFDT(DT,30)
SNOMED ;unfold all snomed subsets
I $T(SUBLST^BSTSAPI)="" Q ;NO SNOMED STUFF INSTALLED
K ^XTMP("BGPSNOMEDSUBSET",$J)
S BGPDA=0 F S BGPDA=$O(^BGPSNOSR(BGPDA)) Q:BGPDA'=+BGPDA D
.S N=$P(^BGPSNOSR(BGPDA,0),U,1) ;subset name
.K ^TMP($J,"SUB")
.S OUT=$NA(^TMP($J,"SUB"))
.S X=$$SUBLST^BSTSAPI(OUT,N) ;
.;BUILD INDEX
.S C=0 F S C=$O(^TMP($J,"SUB",C)) Q:C'=+C S I=$P(^TMP($J,"SUB",C),U,1) I I]"" S ^XTMP("BGPSNOMEDSUBSET",$J,N,I)=^TMP($J,"SUB",C)
.K ^TMP($J,"SUB")
.Q
S ^XTMP("BGPSNOMEDSUBSET",0)=$$FMADD^XLFDT(DT,30)
Q
BGP8UTL2 ; IHS/CMI/LAB - UTILITIES 06 Jan 2017 9:49 AM ; 08 Jan 2018 7:50 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
CODEN(X,F) ;EP - GET CODE
+1 IF $DATA(^ICDS(0))
QUIT $$CODEN^ICDEX(X,F)
+2 QUIT $$CODEN^ICDCODE(X,F)
+3 ;
ICD(VAL,TAXIEN,TYP) ;EP - CHECK TAX
+1 ;add 3rd param with pass type
+2 ;WILL ALWAYS BE ATXAX, NOT LAB
+3 IF $GET(VAL)=""
QUIT 0
+4 NEW TAXNM
+5 SET TAXNM=$PIECE($GET(^ATXAX(TAXIEN,0)),U,1)
+6 IF TAXNM=""
QUIT $$ICD^ATXCHK(VAL,TAXIEN,TYP)
+7 IF '$DATA(^XTMP("BGP15TAX",$JOB,TAXNM))
QUIT $$ICD^ATXCHK(VAL,TAXIEN,TYP)
+8 IF $DATA(^XTMP("BGP15TAX",$JOB,TAXNM,VAL))
QUIT 1
+9 ;Q $$ICD^ATXCHK(VAL,TAXIEN,TYPE)
+10 QUIT 0
+11 ;
+12 ;
ICDDX(C,D,I) ;EP - GET CODE
+1 IF $DATA(^ICDS(0))
QUIT $$ICDDX^ICDEX(C,$GET(D))
+2 QUIT $$ICDDX^ICDCODE(C,$GET(D),$GET(I))
+3 ;
ICDOP(C,D,I) ;EP - GET CODE
+1 IF $GET(I)=""
SET I="I"
+2 IF $DATA(^ICDS(0))
QUIT $$ICDOP^ICDEX(C,$GET(D),,I)
+3 QUIT $$ICDOP^ICDCODE(C,$GET(D))
+4 ;
VSTD(C,D) ;EP
+1 IF $DATA(^ICDS(0))
QUIT $$VSTD^ICDEX(C,$GET(D))
+2 QUIT $$VSTD^ICDCODE(C,$GET(D))
+3 ;
VSTP(C,D) ;EP
+1 IF $DATA(^ICDS(0))
QUIT $$VSTP^ICDEX(C,$GET(D))
+2 QUIT $$VSTP^ICDCODE(C,$GET(D))
+3 ;
ICDD(C,A,D) ;EP
+1 IF $DATA(^ICDS(0))
QUIT $$ICDD^ICDEX(C,A,$GET(D))
+2 QUIT $$ICDD^ICDCODE(C,A,$GET(D))
EDD(P,BDATE,EDATE) ;EP - find EDD
+1 NEW EDD,X,Y,Z,D,W,D,A
+2 SET EDD=""
+3 ;first check bjpn prenatal file
+4 SET Z=$$FMADD^XLFDT(EDATE,243)
+5 SET X=0
FOR
SET X=$ORDER(^BJPNPL("D",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET Y=$$GET1^DIQ(90680.01,X,.09,"I")
+7 IF Y<BDATE
QUIT
+8 IF Y>Z
QUIT
+9 IF Y>EDD
SET EDD=Y
End DoDot:1
+10 IF EDD
QUIT EDD
+11 ;NEXT CHECK EDD IN 9000017
+12 SET Y=$PIECE($GET(^AUPNREP(P,13)),U,11)
+13 IF Y>EDD
SET EDD=Y
+14 IF EDD
QUIT EDD
+15 ;FIND LAST RECORDED EGA VALUE
+16 SET Y=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","EGA")
+17 IF Y
Begin DoDot:1
+18 SET Z=$PIECE(Y,U,2)
SET R=$PIECE(Y,U,4)
+19 SET W=$PIECE(R," ",1)
+20 SET D=+$PIECE($PIECE(R," ",2),"/")
+21 SET A=(W*7)+D
+22 SET A=280-A
+23 SET EDD=$$FMADD^XLFDT(Z,A)
+24 IF EDD'>BDATE
SET EDD=""
End DoDot:1
IF EDD
QUIT EDD
+25 QUIT EDD
+26 ;
GETDIR() ;EP - get default directory
+1 NEW D
+2 SET D=""
+3 SET D=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,14)
+4 IF D]""
QUIT D
+5 SET D=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
+6 IF D]""
QUIT D
+7 SET D=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
+8 IF D]""
QUIT D
+9 IF $PIECE(^AUTTSITE(1,0),U,21)=1
SET D="/usr/spool/uucppublic/"
+10 QUIT D
GETDEDIR() ;EP - get default directory
+1 NEW D
+2 SET D=""
+3 SET D=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
+4 IF D]""
QUIT D
+5 SET D=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
+6 IF D]""
QUIT D
+7 IF $PIECE(^AUTTSITE(1,0),U,21)=1
SET D="/usr/spool/uucppublic/"
+8 QUIT D
DIRCHK ;EP - CALLED FROM INPUT TX ON SITE PARAMETER
+1 NEW BGPX,BGPL,BGPHOLDX
+2 SET BGPHOLDX=X
+3 SET BGPX=$$LIST^%ZISH(X,"*.*",.BGPL)
+4 IF BGPX
DO EN^DDIOL("Not a valid directory!")
KILL X,BGPX,BGPY
QUIT
+5 SET X=BGPHOLDX
+6 KILL BGPL,BGPX
+7 QUIT
+8 ;
GETMEDS(P,BGPMBD,BGPMED,TAXM,TAXN,TAXC,BGPDNAME,BGPZ,TAXRXN) ;EP
+1 SET TAXM=$GET(TAXM)
+2 SET TAXN=$GET(TAXN)
+3 SET TAXC=$GET(TAXC)
+4 SET TAXRXN=$GET(TAXRXN)
+5 KILL ^TMP($JOB,"MEDS"),BGPZ
+6 SET BGPDNAME=$GET(BGPDNAME)
+7 NEW BGPC1,BGPINED,BGPINBD,BGPMIEN,BGPD,X,Y,T,T1,D,G,T2,T3
+8 SET BGPC1=0
KILL BGPZ
+9 SET BGPINED=(9999999-BGPMED)-1
SET BGPINBD=(9999999-BGPMBD)
+10 FOR
SET BGPINED=$ORDER(^AUPNVMED("AA",P,BGPINED))
IF BGPINED=""!(BGPINED>BGPINBD)
QUIT
Begin DoDot:1
+11 SET BGPMIEN=0
FOR
SET BGPMIEN=$ORDER(^AUPNVMED("AA",P,BGPINED,BGPMIEN))
IF BGPMIEN'=+BGPMIEN
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVMED(BGPMIEN,0))
QUIT
+13 SET BGPD=$PIECE(^AUPNVMED(BGPMIEN,0),U)
+14 IF BGPD=""
QUIT
+15 IF '$DATA(^PSDRUG(BGPD,0))
QUIT
+16 SET BGPC1=BGPC1+1
+17 SET ^TMP($JOB,"MEDS","ORDER",(9999999-BGPINED),BGPC1)=(9999999-BGPINED)_U_$PIECE(^PSDRUG(BGPD,0),U)_U_$PIECE(^PSDRUG(BGPD,0),U)_U_BGPMIEN_U_$PIECE(^AUPNVMED(BGPMIEN,0),U,3)
End DoDot:2
End DoDot:1
+18 ;reorder
+19 SET BGPC1=0
SET X=0
+20 FOR
SET X=$ORDER(^TMP($JOB,"MEDS","ORDER",X))
IF X'=+X
QUIT
Begin DoDot:1
+21 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"MEDS","ORDER",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+22 SET BGPC1=BGPC1+1
+23 SET ^TMP($JOB,"MEDS",BGPC1)=^TMP($JOB,"MEDS","ORDER",X,Y)
End DoDot:2
End DoDot:1
+24 KILL ^TMP($JOB,"MEDS","ORDER")
+25 SET T=""
IF TAXM]""
SET T=$ORDER(^ATXAX("B",TAXM,0))
IF T=""
WRITE BGPBOMB
+26 SET T1=""
IF TAXN]""
SET T1=$ORDER(^ATXAX("B",TAXN,0))
IF T1=""
WRITE BGPBOMB
+27 SET T2=""
IF TAXC]""
SET T2=$ORDER(^ATXAX("B",TAXC,0))
+28 SET T3=""
IF TAXRXN]""
SET T3=$ORDER(^ATXAX("B",TAXRXN,0))
+29 SET BGPC1=0
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+30 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+31 SET G=0
+32 SET D=$PIECE(^AUPNVMED(Y,0),U)
+33 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+34 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
+35 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
+36 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",C))
SET G=1
+37 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+38 IF BGPDNAME]""
IF $PIECE(^PSDRUG(D,0),U)[BGPDNAME
SET G=1
+39 SET C=$$VAL^XBDIQ1(9000010.14,Y,9999999.27)
+40 IF C]""
IF T3
IF $DATA(^ATXAX(T3,21,"B",C))
SET G=1
+41 ;WANTS ALL MEDS
IF TAXM=""
IF TAXN=""
IF TAXC=""
IF TAXRXN=""
SET G=1
+42 IF G=1
SET BGPC1=BGPC1+1
SET BGPZ(BGPC1)=^TMP($JOB,"MEDS",X)
+43 QUIT
End DoDot:1
+44 KILL ^TMP($JOB,"MEDS")
+45 KILL BGPINED,BGPINBD,BGPMBD,BGPMED,BGPD,BGPC1,BGPDNAME
+46 QUIT
RCIS(P,BDATE,EDATE,ICDC,CPTC) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+3 IF $GET(EDATE)=""
SET EDATE=DT
+4 SET ICDC=$GET(ICDC)
+5 SET CPTC=$GET(CPTC)
+6 ;find a referral in date range BDATE to EDATE
+7 NEW ICDCAT,CPTCAT,X,Y,D,A,B,G
+8 FOR X=1:1
SET Y=$PIECE(ICDC,";",X)
IF Y=""
QUIT
SET Y=$ORDER(^BMCTDXC("B",Y,0))
IF Y
SET ICDCAT(Y)=""
+9 FOR X=1:1
SET Y=$PIECE(CPTC,";",X)
IF Y=""
QUIT
SET Y=$ORDER(^BMCTSVC("B",Y,0))
IF Y
SET CPTCAT(Y)=""
+10 SET X=0
SET G=""
FOR
SET X=$ORDER(^BMCREF("D",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+11 ;bad xref
IF '$DATA(^BMCREF(X,0))
QUIT
+12 SET D=$PIECE(^BMCREF(X,0),U,1)
SET D=$PIECE(D,".")
+13 ;before date range
IF D<BDATE
QUIT
+14 ;after end date
IF D>EDATE
QUIT
+15 SET Y=$PIECE(^BMCREF(X,0),U,12)
+16 ;want certain categories and this one blank
IF $DATA(ICDCAT)
IF Y=""
QUIT
+17 ;want certain categories and this one doesn't match
IF $DATA(ICDCAT)
IF '$DATA(ICDCAT(Y))
QUIT
+18 SET Y=$PIECE(^BMCREF(X,0),U,13)
+19 ;want certain categories and this one blank
IF $DATA(CPTCAT)
IF Y=""
QUIT
+20 ;want certain categories and this one doesn't match
IF $DATA(CPTCAT)
IF '$DATA(CPTCAT(Y))
QUIT
+21 SET G=X
End DoDot:1
+22 IF 'G
QUIT ""
+23 SET X=""
FOR Y=.07,.08,.09
SET A=$$VAL^XBDIQ1(90001,G,Y)
IF A]""
IF X]""
SET X=X_"; "
+24 QUIT 1_"^"_$PIECE($PIECE(^BMCREF(G,0),U),".")_"^"_$$DATE^BGP8UTL($PIECE($PIECE(^BMCREF(G,0),U),"."))_"^"_"RCIS referral"_"^"_X_"^"_"90001"_"^"_G
+25 ;
CHKDST() ;EP - check the demo patient search template to see if it is complete
+1 ;return a 1 if template is okay
+2 ;return a 0^message if it isn't
+3 ;if it isn't the caller should ask the user if they want to continue
+4 NEW X
+5 SET X=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
+6 IF 'X
QUIT "0^RPMS DEMO PATIENT NAMES Search Template does not exist"
+7 IF '$ORDER(^DIBT(X,1,0))
QUIT "0^RPMS DEMO PATIENT NAMES Search Template has no entries"
+8 QUIT 1
DSTCONT() ;EP - called to ask user if they want to continue
+1 NEW DIR,X,Y,DIRUT
+2 WRITE !!,"Your ",$PIECE(BGPDPST,U,2),".",!,"If you have 'DEMO' patients whose names begin with something"
+3 WRITE !,"other than 'DEMO,PATIENT' they will not be excluded from this report"
+4 WRITE !,"unless you update this template.",!
+5 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue to generate this report"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
QUIT 0
+7 IF 'Y
QUIT 0
+8 QUIT 1
DEMOCHK() ;EP - called to check demo patient
+1 NEW BGPDPST
+2 SET BGPDPST=$$CHKDST()
+3 ;no action, demo template is okay
IF BGPDPST
QUIT 1
+4 SET BGPDPST=$$DSTCONT()
+5 QUIT BGPDPST
+6 ;
UNFOLDTX ;EP
+1 KILL ^XTMP("BGP15TAX",$JOB)
+2 ;lets go through all the taxonomies needed here and put them in above location
+3 ;icd10 isn't there so don't bother
IF '$DATA(^ICDS(0))
GOTO SNOMED
+4 NEW BGPDA,BGPTAX,BGPFL,BGPTAXI,BGPVAL,BGPTYP,BGPTGT,OUT,N
+5 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^BGPTAXR(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+6 SET BGPTAX=$PIECE($GET(^BGPTAXR(BGPDA,0)),U)
+7 SET BGPFL=$PIECE($GET(^BGPTAXR(BGPDA,0)),U,2)
+8 ;only dx, proc, cpt for now
IF BGPFL'="C"
IF BGPFL'="D"
IF BGPFL'="P"
QUIT
+9 SET BGPTYP=""
+10 SET BGPTAXI=$ORDER(^ATXAX("B",BGPTAX,0))
+11 IF BGPTYP="L"
Begin DoDot:2
+12 SET BGPTAXI=$ORDER(^ATXLAB("B",BGPTAX,0))
End DoDot:2
+13 SET BGPTGT="^XTMP("_"""BGP15TAX"""_","_$JOB_","_""""_BGPTAX_""""_")"
+14 DO BLDTAX^ATXAPI(BGPTAX,BGPTGT,BGPTAXI,BGPTYP)
End DoDot:1
+15 SET ^XTMP("BGP15TAX",0)=$$FMADD^XLFDT(DT,30)
SNOMED ;unfold all snomed subsets
+1 ;NO SNOMED STUFF INSTALLED
IF $TEXT(SUBLST^BSTSAPI)=""
QUIT
+2 KILL ^XTMP("BGPSNOMEDSUBSET",$JOB)
+3 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^BGPSNOSR(BGPDA))
IF BGPDA'=+BGPDA
QUIT
Begin DoDot:1
+4 ;subset name
SET N=$PIECE(^BGPSNOSR(BGPDA,0),U,1)
+5 KILL ^TMP($JOB,"SUB")
+6 SET OUT=$NAME(^TMP($JOB,"SUB"))
+7 ;
SET X=$$SUBLST^BSTSAPI(OUT,N)
+8 ;BUILD INDEX
+9 SET C=0
FOR
SET C=$ORDER(^TMP($JOB,"SUB",C))
IF C'=+C
QUIT
SET I=$PIECE(^TMP($JOB,"SUB",C),U,1)
IF I]""
SET ^XTMP("BGPSNOMEDSUBSET",$JOB,N,I)=^TMP($JOB,"SUB",C)
+10 KILL ^TMP($JOB,"SUB")
+11 QUIT
End DoDot:1
+12 SET ^XTMP("BGPSNOMEDSUBSET",0)=$$FMADD^XLFDT(DT,30)
+13 QUIT
