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