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

ATXBULL.m

Go to the documentation of this file. 
  1. ATXBULL ; IHS/OHPRD/TMJ - THE ROUTINE TO TRIGGER PT TAXONOMY BULLETIN ; 13 Oct 2016  3:44 PM
  1.  ;;5.1;TAXONOMY;**11,14,15,17,18**;FEB 04, 1997;Build 31
  1.  ;
  1. EN ; ENTRY POINT
  1.  ;THIS ROUTINE IS SENT THE V POV-DFN (ATXPOVDA) AND THE TAXONOMY DFN
  1.  ;(ATXDT) BY THE TAXONOMY SYSTEM ROUTINE ^ATXPOV.  ATXBULL SETS
  1.  ;NECESSARY VARIABLES THEN SENDS A BULLETIN TO REGISTERED RECIPIENTS TO
  1.  ;NOTIFY THEM OF A PCC VISIT BASED ON THE TAXONOMY'S RELATED ICD'S
  1.  ;D ^XBKVAR
  1.  NEW ATXQUIT
  1.  S ATXQUIT=0
  1.  D INIT
  1.  D EXIT
  1.  Q
  1.  ;
  1.  ;
  1. EXIT K ATXDOLH,ATXDT,ATXPDFN,ATXDUZ,ATXI,ATXJ,ATXVST
  1.  K %X,%Y,X1,X2
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1.  ;
  1. INIT ;
  1.  S X=0
  1. CHK ;
  1.  I '$D(^AUPNVPOV(ATXPOVDA)) G X1
  1.  G:X>100 X1  ;100
  1.  I '$P(^AUPNVPOV(ATXPOVDA,0),U,3) H 5 S X=X+1 G CHK
  1.  I +^AUPNVPOV(ATXPOVDA,0)'=ATXICD G X1
  1.  ;check to see if bulletin should be sent at all
  1.  K ATXSTOP
  1.  Q:$P(^ATXAX(ATXDT,0),U,7)=""
  1.  Q:'$D(^XMB(3.6,$P(^ATXAX(ATXDT,0),U,7),0))  ;quit if no bulletin
  1.  S ATXVISDA=$P(^AUPNVPOV(ATXPOVDA,0),U,3)
  1.  I $P(^ATXAX(ATXDT,0),U,11)]"",$P(^AUPNVSIT(ATXVISDA,0),U,7)_"B"'[$P(^ATXAX(ATXDT,0),U,11) G X1  ;not correct service category
  1.  ;
  1.  I $P(^ATXAX(ATXDT,0),U,3)]"",$P(^AUPNVSIT(ATXVISDA,0),U,6)'=$P(^ATXAX(ATXDT,0),U,3) G X1  ;not correct location and location value exists
  1.  ;
  1.  I $P(^ATXAX(ATXDT,0),U,21)'="" D CHECK3 I ATXQUIT G X1 ;Exit if the Bulletin Visit Type is not contained in Visit Type
  1.  ;
  1.  I $P(^ATXAX(ATXDT,0),U,17)="N" D CHECK I ATXQUIT G X1 ;Exit if same POV in 30 days
  1.  ;
  1.  I $P(^ATXAX(ATXDT,0),U,19)="1" D CHECK2 I ATXQUIT G X1 ;Exit if REVISIT
  1.  ;
  1.  I $P(^ATXAX(ATXDT,0),U,23)=1 D CHECK4 I ATXQUIT G X1  ;exit if only want 1st instance of the dx
  1.  ;
  1.  I $G(^ATXAX(ATXDT,31))]"" X ^ATXAX(ATXDT,31) I $D(ATXSTOP) K ATXSTOP G X1  ;PRE BULLETIN CODE
  1.  D DIQ1
  1. X1 ;K ATXPOVDA,ATXDT
  1.  Q
  1.  ;
  1. CHECK ; If pt had same pov within last 30 days don't send another bulletin
  1.  S ATXVDATE=$P($P(^AUPNVSIT($P(^AUPNVPOV(ATXPOVDA,0),U,3),0),U),".")
  1.  S X1=ATXVDATE,X2=-30 D C^%DTC S ATXID=9999999-X
  1.  S ATXPTDA=$P(^AUPNVPOV(ATXPOVDA,0),U,2)
  1.  S ATXVDATE=9999999-ATXVDATE F  S ATXVDATE=$O(^AUPNVPOV("AA",ATXPTDA,ATXVDATE)) Q:ATXVDATE>ATXID!('$D(ATXPOVDA))!('ATXVDATE)  D
  1.  . S ATXGETDA=0 F  S ATXGETDA=$O(^AUPNVPOV("AA",ATXPTDA,ATXVDATE,ATXGETDA)) Q:'ATXGETDA  I ATXICD=+^AUPNVPOV(ATXGETDA,0) S ATXQUIT=1 Q
  1.  K ATXPTDA,ATXGETDA,ATXID,ATXVDATE
  1.  Q
  1.  ;
  1.  ;
  1. CHECK2 ;Don't send bulletin if NOT First Visit
  1.  ;
  1.  I $P(^AUPNVPOV(ATXPOVDA,0),U,8)'=1 S ATXQUIT=1 Q  ;Kill ATXPOVDA if a REVISIT
  1.  Q
  1. CHECK4 ;
  1.  ;IHS/CMI/LAB - PATCH 17 NEW CODE TO CHECK FOR FIRST DX
  1.  ;the bulletin will only get fired
  1.  ;if this was the first dx the patient had within this taxonomy
  1. NEWCASE ;EP -- called by taxonomy system
  1.  Q:'ATXPOVDA
  1.  Q:'$P(^AUPNVPOV(ATXPOVDA,0),U,2)
  1.  ; -- is this the first of this diagnosis (ICD dx) for this patient
  1.  NEW APCL,APCLY,APCLX,APCLER,V,X,Y,DA,D0
  1.  S APCLY="APCL("
  1.  S APCLX=$P(^AUPNVPOV(ATXPOVDA,0),U,2)_"^FIRST DX ["_$P(^ATXAX(ATXT,0),U,1) S APCLER=$$START1^APCLDF(APCLX,APCLY)
  1.  I APCLER S ATXQUIT=1 G X2
  1.  S V=+$P($G(APCL(1)),U,4) I V=ATXPOVDA G X2
  1.  S ATXQUIT=1
  1. X2 ;
  1.  Q
  1.  ;
  1. CHECK3 ;Don't send bulletin if Bulletin Visit Type is Not contained in Visit Type
  1.  S ATXTYPE=$P(^ATXAX(ATXDT,0),U,21) ;Visit Type for which to send bulletins
  1.  Q:ATXTYPE=""  ;No visit types
  1.  S ATXVST=$P($G(^AUPNVPOV(ATXPOVDA,0)),U,3) ;Get Visit IEN
  1.  I ATXTYPE'[$P($G(^AUPNVSIT(ATXVST,0)),U,3) S ATXQUIT=1 Q  ;S ATXQUIT=1 if NOT Right Visit Type
  1.  Q
  1.  ;
  1. DIQ1 ;
  1.  S DIC="9000010.07",DR=".01:.04;.07;.08;.09;.11;.13",(DA,D0)=ATXPOVDA
  1.  D EN^DIQ1
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.01)) XMB(1)=^(.01) ;POV
  1.  ;S:$D(ATXICD) XMB(8)=$P(^ICD9(ATXICD,0),U,3)
  1.  S:ATXICD XMB(8)=$P($$ICDDX^ICDEX(ATXICD,$P($P(^AUPNVSIT($P(^AUPNVPOV(DA,0),U,3),0),U),".")),U,4)
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.02)) XMB(2)=^(.02) ;PT NAME
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.03)) XMB(3)=^(.03) ;VISIT DATE
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.04)) XMB(4)=^(.04) ;NARRATIVE
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.07)) XMB(7)=^(.07) ;NARRATIVE
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.09)) XMB(9)=^(.09) ;INJURY CAUS
  1.  I $D(XMB(9)),XMB(9)]"" S XMB(9.1)=$P($$ICDDX^ICDEX(XMB(9),$P($P(^AUPNVSIT($P(^AUPNVPOV(DA,0),U,3),0),U),".")),U,4)
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.11)) XMB(11)=^(.11) ;ACC PLACE
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.13)) XMB(13)=^(.13) ;INJURY DATE
  1.  S:$D(^UTILITY("DIQ1",$J,9000010.07,DA,.08)) XMB(14)=^(.08) ;1ST/REVSIT
  1.  ;ABOVE LINE ADDED FOR INJURY,USED 14, FLD 8 USED BY ICD DIQ1+4
  1.  S XMB(20)=$P(^ATXAX(ATXDT,0),U)
  1.  S ATXPDFN=$P(^AUPNVPOV(DA,0),U,2)
  1.  S ATXVST=$S($P(^ATXAX(ATXDT,0),U,3):$P(^(0),U,3),1:$P(^AUPNVSIT($P(^AUPNVPOV(DA,0),U,3),0),U,6))
  1.  I $D(^AUPNPAT(ATXPDFN,41,ATXVST,0)) S XMB(99)=$S($P(^AUTTLOC(ATXVST,0),U,7)]"":$P(^(0),U,7),1:"  ")_" "_$P(^AUPNPAT(ATXPDFN,41,ATXVST,0),U,2)
  1.  E  I $D(DUZ(2))#2,DUZ(2) S:$D(^AUPNPAT(ATXPDFN,41,DUZ(2),0)) XMB(99)=$S($P(^AUTTLOC(DUZ(2),0),U,7)]"":$P(^(0),U,7),1:"  ")_" "_$P(^AUPNPAT(ATXPDFN,41,DUZ(2),0),U,2)
  1.  S XMB(15)=$P(^DIC(4,$P(^AUPNVSIT($P(^AUPNVPOV(DA,0),U,3),0),U,6),0),U)
  1.  ;IHS/CMI/GRL  multiple additions
  1.  S ATXCOM=$P($G(^AUPNPAT(ATXPDFN,11)),U,17) I $G(ATXCOM)]"" S XMB(16)=$P(^AUTTCOM(ATXCOM,0),U) ;current residence 
  1.  I $G(ATXCOM)]"" S ATXSU=$P($G(^AUTTCOM(ATXCOM,0)),U,5) I ATXSU]"" S XMB(17)=$P($G(^AUTTSU(ATXSU,0)),U)  ;service unit  ;IHS/CMI/GRL **5**
  1.  S X=$P(^DPT(ATXPDFN,0),U,3),XMB(18)=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+($E(X,1,3)))  ;dob
  1.  S X=$P($G(^AUPNPAT(ATXPDFN,11)),U,8),XMB(19)=$S(X:$P(^AUTTTRI(X,0),U),1:"")  ;tribe
  1.  S XMB(21)=$P($G(^AUPNPAT(ATXPDFN,11)),U,9)  ;tribal quantum
  1.  S X=$P($G(^AUPNPAT(ATXPDFN,11)),U,27) I X]"" S XMB(22)="Pre-bic Tribe: "_$P(^AUTTTRI(X,0),U) ;pre-bic tribe
  1.  S X=$P($G(^DPT(ATXPDFN,0)),U,9) S XMB(23)=$S(X:"XXX-XX-"_$E(X,6,9),1:"Not on file")   ;IHS/CMI/GRL **4** SSN 
  1.  ;
  1. GETHRNS ;Get all HRN's for this patient 
  1.  I $D(^AUPNPAT(ATXPDFN,41)) D
  1.  .Q:$P(^AUPNPAT(ATXPDFN,41,0),U,4)=1
  1.  .S ATXFAC=0,CTR=30
  1.  .F  S ATXFAC=$O(^AUPNPAT(ATXPDFN,41,ATXFAC)) Q:'ATXFAC  D
  1.  ..S ATXHRN=$P(^AUPNPAT(ATXPDFN,41,ATXFAC,0),U,2),XMB(CTR)=$P(^DIC(4,ATXFAC,0),U)_" ("_ATXHRN_")" S CTR=CTR+1
  1.  ;
  1.  I ATXDT,$D(^ATXAX(ATXDT,0)),$P(^ATXAX(ATXDT,0),U,7)]"" S XMB=$P(^XMB(3.6,$P(^ATXAX(ATXDT,0),U,7),0),U)
  1.  S ATXDUZ=DUZ,DUZ=.5
  1.  ;S ^LORIBULL(ATXPOVDA)="MADE IT TO XMB"
  1.  D ^XMB S DUZ=ATXDUZ
  1.  K XMB,^UTILITY("DIQ1",$J,9000010.07,DA)
  1.  K ATXCOM,ATXSU,ATXFAC,ATXHRN
  1.  Q