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

BATU.m

Go to the documentation of this file. 
  1. BATU ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
  1.  ;;1.0;IHS ASTHMA REGISTER;;FEB 19, 2003
  1.  ;
  1.  ;
  1. NREL(P,BDATE,EDATE) ;EP
  1.  ;number of reliever meds between BDATE and EDATE
  1.  NEW X,BATL,E
  1.  S X=P_"^ALL MEDS [BAT ASTHMA RELIEVER MEDS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BATL(")
  1.  I '$D(BATL(1)) Q 0
  1.  NEW C,X S (X,C)=0 F  S X=$O(BATL(X)) Q:X'=+X  S C=C+1
  1.  Q C
  1.  ;
  1. PLAST(P,F) ;PEP
  1.  ;1 return 1 if yes, null if no
  1.  ;2 return problem number _ provdier narrative
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW I,A,B,G,S
  1.  S G="",A=0 F  S A=$O(^AUPNPROB("AC",P,A)) Q:A'=+A!(G]"")  D
  1.  .S I=$P(^AUPNPROB(A,0),U),I=$P(^ICD9(I,0),U)
  1.  .I $E(I,1,3)'="493" Q
  1.  .S G=A
  1.  .Q
  1.  I G="" Q ""
  1.  I F=1 Q 1
  1.  I F=2 S G=$$PLN(G) Q G
  1.  Q ""
  1. DXAST(P) ;PEP
  1.  I '$G(P) Q ""
  1.  NEW D,I,A,G
  1.  S (D,G)=0 F  S D=$O(^AUPNVPOV("AA",P,D)) Q:D'=+D!(G)  D
  1.  .S I=0 F  S I=$O(^AUPNVPOV("AA",P,D,I)) Q:I'=+I!(G)  D
  1.  ..S A=$P(^AUPNVPOV(I,0),U),A=$P(^ICD9(A,0),U)
  1.  ..Q:$E(A,1,3)'="493"
  1.  ..S G=1
  1.  ..Q
  1.  .Q
  1.  Q G
  1. PLN(E) ;
  1.  NEW S
  1.  S S=$P(^AUPNPROB(E,0),U,6),S=$S($P(^AUTTLOC(S,0),U,7)]"":$P(^AUTTLOC(S,0),U,7),1:"??")
  1.  Q S_$P(^AUPNPROB(E,0),U,7)_"  "_$$VAL^XBDIQ1(9000011,E,.05)_$S($P(^AUPNPROB(E,0),U,12)="I":" (INACTIVE)",1:"")
  1. NEXT(E) ;EP - called from trigger
  1.  I '$G(E) Q ""
  1.  I '$D(^BATREG(E,0)) Q ""
  1.  NEW BATLD
  1.  S BATLD=$$LASTAV(E,2)
  1.  I BATLD="" Q ""
  1.  S BATLS=$$LASTSEV($P(^BATREG(E,0),"^"))
  1.  I BATLS=1 Q ""
  1.  Q $$FMADD^XLFDT(BATLD,(6*30))
  1.  ;
  1. LASTPBF(P,F) ;EP
  1.  ;1 value
  1.  ;2 external date
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW G,D,D1,E,BATL
  1.  S G="",D=0 K BATL F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(G]"")  D
  1.  .K BATL S E=0 F  S E=$O(^AUPNVAST("AA",P,D,E)) Q:E'=+E  I $P(^AUPNVAST(E,0),U,7)]"" S BATL(9999999-E)=$P(^AUPNVAST(E,0),U,7)_"^"_(9999999-D)
  1.  .I $D(BATL) S E=$O(BATL(0)),G=$P(BATL(E),U),D1=$P(BATL(E),U,2)
  1.  I '$D(BATL) Q ""
  1.  I F=1 Q G
  1.  I F=2 Q $$FMTE^XLFDT(D1)
  1.  I F=3 Q D1
  1.  Q ""
  1. LASTFV2(P,F) ;EP - return last fev25-75
  1.  ;1 value
  1.  ;2 external date
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW G,D,D1,E,BATL
  1.  S G="",D=0 K BATL F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(G]"")  D
  1.  .K BATL S E=0 F  S E=$O(^AUPNVAST("AA",P,D,E)) Q:E'=+E  I $P(^AUPNVAST(E,0),U,6)]"" S BATL(9999999-E)=$P(^AUPNVAST(E,0),U,6)_"^"_(9999999-D)
  1.  .I $D(BATL) S E=$O(BATL(0)),G=$P(BATL(E),U),D1=$P(BATL(E),U,2)
  1.  I '$D(BATL) Q ""
  1.  I F=1 Q G
  1.  I F=2 Q $$FMTE^XLFDT(D1)
  1.  I F=3 Q D1
  1.  Q ""
  1. LASTSEVD(P,F,EDATE) ;EP - return last severity before a certain date
  1.  ;1 - internal set of codes
  1.  ;2 - internal date
  1.  ;3 - external date
  1.  ;4 - external name
  1.  ;5 - code and external name
  1.  NEW D,LAST,E,S
  1.  I '$G(P) Q ""
  1.  I '$G(EDATE) S EDATE=DT
  1.  I '$G(F) S F=1
  1.  NEW EDATE1 S EDATE1=9999999-EDATE-1
  1.  S D=$O(^AUPNVAST("AS",P,EDATE1))
  1.  I 'D Q ""
  1.  S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E
  1.  I 'LAST Q ""
  1.  S S=^AUPNVAST("AS",P,D,LAST)
  1.  I F=1 Q S
  1.  I F=2 Q 9999999-D
  1.  I F=3 Q $$FMTE^XLFDT(9999999-D)
  1.  I F=4 Q $$EXTSET^XBFUNC(9000010.41,.04,S)
  1.  I F=5 Q S_"-"_$$EXTSET^XBFUNC(9000010.41,.04,S)
  1.  Q ""
  1.  ;
  1. LASTETS(P,F) ;EP
  1.  ;1 value
  1.  ;2 external date
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW G,D,D1,E,BATL
  1.  S G="",D=0 K BATL F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(G]"")  D
  1.  .K BATL S E=0 F  S E=$O(^AUPNVAST("AA",P,D,E)) Q:E'=+E  I $P(^AUPNVAST(E,0),U,8)]"" S BATL(9999999-E)=$$VAL^XBDIQ1(9000010.41,E,.08)_"^"_(9999999-D)
  1.  .I $D(BATL) S E=$O(BATL(0)),G=$P(BATL(E),U),D1=$P(BATL(E),U,2)
  1.  I '$D(BATL) Q ""
  1.  I F=1 Q G
  1.  I F=2 Q $$FMTE^XLFDT(D1)
  1.  Q ""
  1. LASTPARM(P,F) ;EP
  1.  ;1 value
  1.  ;2 external date
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW G,D,D1,E,BATL
  1.  S G="",D=0 K BATL F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(G]"")  D
  1.  .K BATL S E=0 F  S E=$O(^AUPNVAST("AA",P,D,E)) Q:E'=+E  I $P(^AUPNVAST(E,0),U,9)]"" S BATL(9999999-E)=$$VAL^XBDIQ1(9000010.41,E,.09)_"^"_(9999999-D)
  1.  .I $D(BATL) S E=$O(BATL(0)),G=$P(BATL(E),U),D1=$P(BATL(E),U,2)
  1.  I '$D(BATL) Q ""
  1.  I F=1 Q G
  1.  I F=2 Q $$FMTE^XLFDT(D1)
  1.  Q ""
  1. LASTDM(P,F) ;EP
  1.  ;1 value
  1.  ;2 external date
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW G,D,D1,E,BATL
  1.  S G="",D=0 K BATL F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(G]"")  D
  1.  .K BATL S E=0 F  S E=$O(^AUPNVAST("AA",P,D,E)) Q:E'=+E  I $P(^AUPNVAST(E,0),U,11)]"" S BATL(9999999-E)=$$VAL^XBDIQ1(9000010.41,E,.11)_"^"_(9999999-D)
  1.  .I $D(BATL) S E=$O(BATL(0)),G=$P(BATL(E),U),D1=$P(BATL(E),U,2)
  1.  I '$D(BATL) Q ""
  1.  I F=1 Q G
  1.  I F=2 Q $$FMTE^XLFDT(D1)
  1.  Q ""
  1. LASTSEV(P,F) ;PEP;return last severity recorded
  1.  ;1 - internal set of codes
  1.  ;2 - internal date
  1.  ;3 - external date
  1.  ;4 - external name
  1.  ;5 - code and external name
  1.  NEW D,LAST,E,S
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  S D=$O(^AUPNVAST("AS",P,0))
  1.  I 'D Q ""
  1.  S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E
  1.  I 'LAST Q ""
  1.  S S=^AUPNVAST("AS",P,D,LAST)
  1.  I F=1 Q S
  1.  I F=2 Q 9999999-D
  1.  I F=3 Q $$FMTE^XLFDT(9999999-D)
  1.  I F=4 Q $$EXTSET^XBFUNC(9000010.41,.04,S)
  1.  I F=5 Q S_"-"_$$EXTSET^XBFUNC(9000010.41,.04,S)
  1.  Q ""
  1.  ;
  1. LASTAM(P,F) ;EP - return date of last asthma management plan = yes
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW D S D=$O(^AUPNVAST("AM",P,0))
  1.  I 'D Q ""
  1.  I F=1 Q 9999999-D
  1.  I F=2 Q $$FMTE^XLFDT(9999999-D)
  1.  Q ""
  1. LASTAV(P,F) ;EP;return last visit with an Asthma V file entry
  1.  I '$G(P) Q ""
  1.  I '$G(F) S F=1
  1.  NEW D S D=$O(^AUPNVAST("AA",P,0))
  1.  I 'D Q ""
  1.  NEW E S E=$O(^AUPNVAST("AA",P,D,0))
  1.  I 'E Q ""
  1.  I F=1 Q $P($G(^AUPNVAST(E,0)),U,3)
  1.  I F=2 Q $P($P(^AUPNVSIT($P(^AUPNVAST(E,0),U,3),0),U),".")
  1.  I F=3 Q $$FMTE^XLFDT($P(^AUPNVSIT($P(^AUPNVAST(E,0),U,3),0),U),"1D")
  1.  Q ""
  1. LASTDX(P) ;EP - return date of last asthma diagnosis
  1.  I $G(P)="" Q 0
  1.  NEW BATX,BATY,I,S,E
  1.  K BATX
  1.  S BATY="BATX("
  1.  S S=P_"^LAST DX [BAT ASTHMA DIAGNOSES" S E=$$START1^APCLDF(S,BATY)
  1.  I '$D(BATX(1)) Q ""
  1.  Q $P(BATX(1),U)
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. XTMP(N,D) ;EP - set xtmp 0 node
  1.  Q:$G(N)=""
  1.  S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
  1.  Q
  1. V ; GET VERSION
  1.  NEW BATV,BATL,BATJ,BATX
  1.  S BATV="1.0"
  1.  I $G(BATTEXT)="" S BATTEXT="TEXT",BATL=3 G PRINT
  1.  S BATTEXT="TEXT"_BATTEXT
  1.  F BATJ=1:1 S BATX=$T(@BATTEXT+BATJ),BATX=$P(BATX,";;",2) Q:BATX="QUIT"!(BATX="")  S BATL=BATJ
  1. PRINT W:$D(IOF) @IOF
  1.  F BATJ=1:1:BATL S BATX=$T(@BATTEXT+BATJ),BATX=$P(BATX,";;",2) W !,$$CTR(BATX,80)
  1.  W !,$$CTR("Version "_BATV)
  1. SITE W !!,$$CTR($$LOC)
  1.  K BATTEXT
  1.  Q
  1. TEXT ;
  1.  ;;**************************
  1.  ;;**   Asthma Register    **
  1.  ;;**************************
  1.  ;;QUIT
  1.  ;
  1. TEXTR ;
  1.  ;;**************************
  1.  ;;**   Asthma Register    **
  1.  ;;**    Reports Menu      **
  1.  ;;**************************
  1.  ;;QUIT
  1. TEXTX ;;
  1.  ;;***************************
  1.  ;;**    Asthma Register    **
  1.  ;;**    QI Reports Menu    **
  1.  ;;***************************
  1.  ;;QUIT
  1.  ;
  1. TEXTP ;;
  1.  ;;******************************
  1.  ;;**     Asthma Register      **
  1.  ;;**    Patient Management    **
  1.  ;;******************************
  1.  ;;QUIT
  1.  ;
  1. TEXTG ;;
  1.  ;;********************************
  1.  ;;**      Asthma Register       **
  1.  ;;**     Register Management    **
  1.  ;;********************************
  1.  ;;QUIT
  1.  ;
  1. TEXTS ;;
  1.  ;;******************************
  1.  ;;**     Asthma Register      **
  1.  ;;**     Register Setup       **
  1.  ;;******************************
  1.  ;;QUIT
  1.  ;
  1. TEXTL ;
  1.  ;;**************************
  1.  ;;**   Asthma Register    **
  1.  ;;**    Letters Menu      **
  1.  ;;**************************
  1.  ;;QUIT
  1.  ;