Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP5UTL2

BGP5UTL2.m

Go to the documentation of this file. 
  1. BGP5UTL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 30 Jun 2015 9:01 AM ;
  1.  ;;17.0;IHS CLINICAL REPORTING;;AUG 30, 2016;Build 16
  1.  ;
  1.  ;
  1. CODEN(X,F) ;EP - GET CODE
  1.  I $D(^ICDS(0)) Q $$CODEN^ICDEX(X,F)
  1.  Q $$CODEN^ICDCODE(X,F)
  1.  ;
  1. ICD(VAL,TAXIEN,TYP) ;EP - CHECK TAX
  1.  ;add 3rd param with pass type
  1.  ;WILL ALWAYS BE ATXAX, NOT LAB
  1.  I $G(VAL)="" Q 0
  1.  NEW TAXNM
  1.  S TAXNM=$P($G(^ATXAX(TAXIEN,0)),U,1)
  1.  I '$D(^XTMP("BGP15TAX",$J,TAXNM)) Q $$ICD^ATXCHK(VAL,TAXIEN,TYP)
  1.  I $D(^XTMP("BGP15TAX",$J,TAXNM,VAL)) Q 1
  1.  Q 0
  1.  ;
  1.  ;
  1. ICDDX(C,D,I) ;EP - GET CODE
  1.  I $D(^ICDS(0)) Q $$ICDDX^ICDEX(C,$G(D))
  1.  Q $$ICDDX^ICDCODE(C,$G(D),$G(I))
  1.  ;
  1. ICDOP(C,D,I) ;EP - GET CODE
  1.  I $G(I)="" S I="I"
  1.  I $D(^ICDS(0)) Q $$ICDOP^ICDEX(C,$G(D),,I)
  1.  Q $$ICDOP^ICDCODE(C,$G(D))
  1.  ;
  1. VSTD(C,D) ;EP
  1.  I $D(^ICDS(0)) Q $$VSTD^ICDEX(C,$G(D))
  1.  Q $$VSTD^ICDCODE(C,$G(D))
  1.  ;
  1. VSTP(C,D) ;EP
  1.  I $D(^ICDS(0)) Q $$VSTP^ICDEX(C,$G(D))
  1.  Q $$VSTP^ICDCODE(C,$G(D))
  1.  ;
  1. ICDD(C,A,D) ;EP
  1.  I $D(^ICDS(0)) Q $$ICDD^ICDEX(C,A,$G(D))
  1.  Q $$ICDD^ICDCODE(C,A,$G(D))
  1. GETDIR() ;EP - get default directory
  1.  NEW D
  1.  S D=""
  1.  S D=$P($G(^BGPSITE(DUZ(2),0)),U,14)
  1.  I D]"" Q D
  1.  S D=$P($G(^AUTTSITE(1,1)),"^",2)
  1.  I D]"" Q D
  1.  S D=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
  1.  I D]"" Q D
  1.  I $P(^AUTTSITE(1,0),U,21)=1 S D="/usr/spool/uucppublic/"
  1.  Q D
  1. GETDEDIR() ;EP - get default directory
  1.  NEW D
  1.  S D=""
  1.  S D=$P($G(^AUTTSITE(1,1)),"^",2)
  1.  I D]"" Q D
  1.  S D=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
  1.  I D]"" Q D
  1.  I $P(^AUTTSITE(1,0),U,21)=1 S D="/usr/spool/uucppublic/"
  1.  Q D
  1. DIRCHK ;EP - CALLED FROM INPUT TX ON SITE PARAMETER
  1.  NEW BGPX,BGPL,BGPHOLDX
  1.  S BGPHOLDX=X
  1.  S BGPX=$$LIST^%ZISH(X,"*.*",.BGPL)
  1.  I BGPX D EN^DDIOL("Not a valid directory!") K X,BGPX,BGPY Q
  1.  S X=BGPHOLDX
  1.  K BGPL,BGPX
  1.  Q
  1.  ;
  1. GETMEDS(P,BGPMBD,BGPMED,TAXM,TAXN,TAXC,BGPDNAME,BGPZ) ;EP
  1.  S TAXM=$G(TAXM)
  1.  S TAXN=$G(TAXN)
  1.  S TAXC=$G(TAXC)
  1.  K ^TMP($J,"MEDS"),BGPZ
  1.  S BGPDNAME=$G(BGPDNAME)
  1.  NEW BGPC1,BGPINED,BGPINBD,BGPMIEN,BGPD,X,Y,T,T1,D,G
  1.  S BGPC1=0 K BGPZ
  1.  S BGPINED=(9999999-BGPMED)-1,BGPINBD=(9999999-BGPMBD)
  1.  F  S BGPINED=$O(^AUPNVMED("AA",P,BGPINED)) Q:BGPINED=""!(BGPINED>BGPINBD)  D
  1.  .S BGPMIEN=0 F  S BGPMIEN=$O(^AUPNVMED("AA",P,BGPINED,BGPMIEN)) Q:BGPMIEN'=+BGPMIEN  D
  1.  ..Q:'$D(^AUPNVMED(BGPMIEN,0))
  1.  ..S BGPD=$P(^AUPNVMED(BGPMIEN,0),U)
  1.  ..Q:BGPD=""
  1.  ..Q:'$D(^PSDRUG(BGPD,0))
  1.  ..S BGPC1=BGPC1+1
  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)
  1.  ;reorder
  1.  S BGPC1=0,X=0
  1.  F  S X=$O(^TMP($J,"MEDS","ORDER",X)) Q:X'=+X  D
  1.  .S Y=0 F  S Y=$O(^TMP($J,"MEDS","ORDER",X,Y)) Q:Y'=+Y  D
  1.  ..S BGPC1=BGPC1+1
  1.  ..S ^TMP($J,"MEDS",BGPC1)=^TMP($J,"MEDS","ORDER",X,Y)
  1.  K ^TMP($J,"MEDS","ORDER")
  1.  S T="" I TAXM]"" S T=$O(^ATXAX("B",TAXM,0)) I T="" W BGPBOMB
  1.  S T1="" I TAXN]"" S T1=$O(^ATXAX("B",TAXN,0)) I T1="" W BGPBOMB
  1.  S T2="" I TAXC]"" S T2=$O(^ATXAX("B",TAXC,0))
  1.  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
  1.  .Q:'$D(^AUPNVMED(Y,0))
  1.  .S G=0
  1.  .S D=$P(^AUPNVMED(Y,0),U)
  1.  .S C=$P($G(^PSDRUG(D,0)),U,2)
  1.  .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
  1.  .S C=$P($G(^PSDRUG(D,2)),U,4)
  1.  .I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
  1.  .I T,$D(^ATXAX(T,21,"B",D)) S G=1
  1.  .I BGPDNAME]"",$P(^PSDRUG(D,0),U)[BGPDNAME S G=1
  1.  .I TAXM="",TAXN="",TAXC="" S G=1  ;WANTS ALL MEDS
  1.  .I G=1 S BGPC1=BGPC1+1,BGPZ(BGPC1)=^TMP($J,"MEDS",X)
  1.  .Q
  1.  K ^TMP($J,"MEDS")
  1.  K BGPINED,BGPINBD,BGPMBD,BGPMED,BGPD,BGPC1,BGPDNAME
  1.  Q
  1. RCIS(P,BDATE,EDATE,ICDC,CPTC) ;EP
  1.  I '$G(P) Q ""
  1.  I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
  1.  I $G(EDATE)="" S EDATE=DT
  1.  S ICDC=$G(ICDC)
  1.  S CPTC=$G(CPTC)
  1.  ;find a referral in date range BDATE to EDATE
  1.  NEW ICDCAT,CPTCAT,X,Y,D,A,B,G
  1.  F X=1:1 S Y=$P(ICDC,";",X) Q:Y=""  S Y=$O(^BMCTDXC("B",Y,0)) I Y S ICDCAT(Y)=""
  1.  F X=1:1 S Y=$P(CPTC,";",X) Q:Y=""  S Y=$O(^BMCTSVC("B",Y,0)) I Y S CPTCAT(Y)=""
  1.  S X=0,G="" F  S X=$O(^BMCREF("D",P,X)) Q:X'=+X!(G)  D
  1.  .Q:'$D(^BMCREF(X,0))  ;bad xref
  1.  .S D=$P(^BMCREF(X,0),U,1),D=$P(D,".")
  1.  .Q:D<BDATE  ;before date range
  1.  .Q:D>EDATE  ;after end date
  1.  .S Y=$P(^BMCREF(X,0),U,12)
  1.  .I $D(ICDCAT),Y="" Q  ;want certain categories and this one blank
  1.  .I $D(ICDCAT),'$D(ICDCAT(Y)) Q  ;want certain categories and this one doesn't match
  1.  .S Y=$P(^BMCREF(X,0),U,13)
  1.  .I $D(CPTCAT),Y="" Q  ;want certain categories and this one blank
  1.  .I $D(CPTCAT),'$D(CPTCAT(Y)) Q  ;want certain categories and this one doesn't match
  1.  .S G=X
  1.  I 'G Q ""
  1.  S X="" F Y=.07,.08,.09 S A=$$VAL^XBDIQ1(90001,G,Y) I A]"" S:X]"" X=X_"; "
  1.  Q 1_"^"_$P($P(^BMCREF(G,0),U),".")_"^"_$$DATE^BGP5UTL($P($P(^BMCREF(G,0),U),"."))_"^"_"RCIS referral"_"^"_X_"^"_"90001"_"^"_G
  1.  ;
  1. CHKDST() ;EP - check the demo patient search template to see if it is complete
  1.  ;return a 1 if template is okay
  1.  ;return a 0^message if it isn't
  1.  ;if it isn't the caller should ask the user if they want to continue
  1.  NEW X
  1.  S X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
  1.  I 'X Q "0^RPMS DEMO PATIENT NAMES Search Template does not exist"
  1.  I '$O(^DIBT(X,1,0)) Q "0^RPMS DEMO PATIENT NAMES Search Template has no entries"
  1.  Q 1
  1. DSTCONT() ;EP - called to ask user if they want to continue
  1.  NEW DIR,X,Y,DIRUT
  1.  W !!,"Your ",$P(BGPDPST,U,2),".",!,"If you have 'DEMO' patients whose names begin with something"
  1.  W !,"other than 'DEMO,PATIENT' they will not be excluded from this report"
  1.  W !,"unless you update this template.",!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue to generate this report",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q 0
  1.  I 'Y Q 0
  1.  Q 1
  1. DEMOCHK() ;EP - called to check demo patient
  1.  NEW BGPDPST
  1.  S BGPDPST=$$CHKDST()
  1.  I BGPDPST Q 1  ;no action, demo template is okay
  1.  S BGPDPST=$$DSTCONT()
  1.  Q BGPDPST
  1.  ;
  1. UNFOLDTX ;EP
  1.  K ^XTMP("BGP15TAX",$J)
  1.  ;lets go through all the taxonomies needed here and put them in above location
  1.  I '$D(^ICDS(0)) G SNOMED  ;icd10 isn't there so don't bother
  1.  NEW BGPDA,BGPTAX,BGPFL,BGPTAXI,BGPVAL,BGPTYP,BGPTGT
  1.  S BGPDA=0 F  S BGPDA=$O(^BGPTAXK(BGPDA)) Q:'BGPDA  D
  1.  . S BGPTAX=$P($G(^BGPTAXK(BGPDA,0)),U)
  1.  . S BGPFL=$P($G(^BGPTAXK(BGPDA,0)),U,2)
  1.  . I BGPFL'="C",BGPFL'="D",BGPFL'="P" Q  ;only dx, proc, cpt for now
  1.  . S BGPTYP=""
  1.  . S BGPTAXI=$O(^ATXAX("B",BGPTAX,0))
  1.  . I BGPTYP="L" D
  1.  .. S BGPTAXI=$O(^ATXLAB("B",BGPTAX,0))
  1.  . S BGPTGT="^XTMP("_"""BGP15TAX"""_","_$J_","_""""_BGPTAX_""""_")"
  1.  . D BLDTAX^ATXAPI(BGPTAX,BGPTGT,BGPTAXI,BGPTYP)
  1.  S ^XTMP("BGP15TAX",0)=$$FMADD^XLFDT(DT,30)
  1. SNOMED ;unfold all snomed subsets
  1.  I $T(SUBLST^BSTSAPI)="" Q  ;NO SNOMED STUFF INSTALLED
  1.  K ^XTMP("BGPSNOMEDSUBSET",$J)
  1.  S BGPDA=0 F  S BGPDA=$O(^BGPSNOSG(BGPDA)) Q:BGPDA'=+BGPDA  D
  1.  .S N=$P(^BGPSNOSG(BGPDA,0),U,1)  ;subset name
  1.  .K ^TMP($J,"SUB")
  1.  .S OUT=$NA(^TMP($J,"SUB"))
  1.  .S X=$$SUBLST^BSTSAPI(OUT,N)  ;LORI
  1.  .;BUILD INDEX
  1.  .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)
  1.  .K ^TMP($J,"SUB")
  1.  .Q
  1.  S ^XTMP("BGPSNOMEDSUBSET",0)=$$FMADD^XLFDT(DT,30)
  1.  Q