ATXPOV ; IHS/OHPRD/TMJ - IF ICD CODE HAS A TAXON, ENTER PAT IN PT TAX FILE ; 07 Feb 2016 5:51 PM
;;5.1;TAXONOMY;**11,14,15**;FEB 04, 1997;Build 20
;IHS/TUCSON/LAB - because of the check for the variable
;IHS/CMI/LAB - patch 1 to version 5.1 allows the autoupdating
;of complications in a CMS register triggered from PCC Data Entry
;6/20/2000
;APCDDATE at the top of this routine, bulletins were not being
;sent if the user was not using PCC Data Entry. This has been
;changed so that bulletins will be fired even if the POV is
;created by a link from another package.
;Q:'$D(APCDDATE)!('$D(DA))!('$D(X))
Q:'$D(DA)!('$D(X)) ;DA IS DA OF aupnvpov, X is internal of ICD code
NEW ATXPOVDA,ATXDI,ATXICD
;ATXVISI visit ien
;ATXVIS visit date
;ATXDFN patient dfn
;ATXPOVDA V POV ien
;kill side of xref, .03 exists
S ATXPOVDA=DA
S ATXDI=X ;ien of icd code
;I $P(^AUPNVPOV(ATXPOVDA,0),U,3) S ATXVISI=$P(^AUPNVPOV(ATXPOVDA,0),U,3),ATXVIS=$$VD^APCLV(ATXVISI),ATXDFN=$P(^AUPNVPOV(ATXPOVDA,0),U,2)
;I '$D(ATXAD),$P(^AUPNVPOV(DA,0),U,3) S ATXVIS=+^AUPNVSIT($P(^AUPNVPOV(DA,0),U,3),0) S:'$D(APCDVSIT) APCDVSIT=$P(^AUPNVPOV(DA,0),U,3) S:'$D(AUPNPAT) AUPNPAT=$P(^AUPNVPOV(DA,0),U,2)
;E S ATXVIS=$P(APCDDATE,".")
;Set ATXVIS with visit Date
;E S ATXVIS=$S($G(APCDDATE):$P(APCDDATE,"."),$G(APCDVSIT):$P($P(^AUPNVSIT(APCDVSIT,0),U),"."),1:"")
;Q:ATXVIS=""
;
;I '$O(^ICD9(ATXDI,9999999.41,0)) D CMSCMPL,EOJ Q ;IHS/CMI/LAB
;NEW FOR AICD 4.0
;loop "ABLT" and call ICD^ATXCHK with X
NEW T,B,G,F
S (B,G)=0 F S B=$O(^ATXAX("ABLT",B)) Q:B'=+B!(G) D
.S T=0 F S T=$O(^ATXAX("ABLT",B,T)) Q:T'=+T!(G) D
..Q:'$D(^ATXAX(T,0))
..I $P(^ATXAX(T,0),U,15)'=80 Q
..I $$ICD^ATXCHK(ATXDI,T,9) S G=1
.Q
I 'G D CMSCMPL Q
I '$D(ATXAD) D CMSCMPL Q ;IF NOT IN SET SIDE THEN JUST DO COMPLICATIONS ***LORI
;
D START
D EOJ
Q
;
;
CALL ;SEE IF PT TAX FILE TO BE UPDATED
Q:'$D(^ATXPAT(ATXDT,0))#2
I ATXVIS<$P(^ATXAX(ATXDT,0),U,6) Q
I $D(ATXAD) D DIEADD^ATXPAT Q
I '$D(ATXAD) D DIEDEL^ATXPAT Q
Q
;
START ;
;
NEW ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTDTH,ZTSK,%
S ATXICD=ATXDI
F %="ATXPOVDA","ATXICD","ATXDI" S ZTSAVE(%)=""
S ZTRTN="START1^ATXPOV"
S ZTDESC="BULLETIN/COMPL TRIGGER FROM PCC DATA ENTRY"
S ZTIO=""
S ZTDTH=$H,$P(ZTDTH,",",2)=$P(ZTDTH,",",2)+300 ;CHANGE TO 300
D ^%ZTLOAD
K ZTSK
X Q
;
START1 ;EP = called from taskman
;call bulletin for any taxonomies that have this code
S ATXDT=""
S ATXB=0 F S ATXB=$O(^ATXAX("ABLT",ATXB)) Q:ATXB'=+ATXB D
.S ATXT=0 F S ATXT=$O(^ATXAX("ABLT",ATXB,ATXT)) Q:ATXT'=+ATXT D
..S ATXDT="" I $$ICD^ATXCHK(ATXDI,ATXT,9) S ATXDT=ATXT D EN^ATXBULL
.Q
D CMSCMPL0
I $D(ZTQUEUED) S ZTREQ="@"
EOJ ;
K ATXDT,ATXL,ATXPD,ATXDI,ATXAD,ATXVIS,ATXDOLH,ATXPOVDA,ATXVISDA,ATXC,ATXR,ATXRCMS,ATXR1
Q
;
CMSCMPL ;
;if this ICD code is in ^ACM(42.1,"DX", xref
;then get registers associated with it
;if this patient is on any of those registers, then update
;their complication list if this isn't already on their list
;S ATXDT=0,ATXPD=AUPNPAT
;maybe this should be tasked to the background ??
Q:ATXDI=""
Q:'$D(^ACM(42.1,"DX",ATXDI)) ;IHS/CMI/LAB - not in any complication list so don't bother
;task off to taskman
;G CMSCMPL0 ;LORI REMOVE
NEW ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,%
F %="ATXDI","ATXPOVDA" S ZTSAVE(%)=""
S ZTRTN="CMSCMPL0^ATXPOV"
S ZTDESC="CMS COMPL TRIGGER FROM PCC DATA ENTRY"
S ZTIO=""
S ZTDTH=$H,$P(ZTDTH,",",2)=$P(ZTDTH,",",2)+300
D ^%ZTLOAD
K ZTSK
Q
CMSCMPL0 ;EP - called from taskman
;SET UP VARS
Q:ATXDI=""
Q:'$D(^ACM(42.1,"DX",ATXDI)) ;IHS/CMI/LAB - not in any complication list so don't bother
NEW ATXC,ATXR,ATXRA,ATXPD
S ATXPD=$P($G(^AUPNVPOV(ATXPOVDA,0)),U,2) ;patient
Q:'ATXPD ;v pov must have been deleted
S ATXC=0 F S ATXC=$O(^ACM(42.1,"DX",ATXDI,ATXC)) Q:ATXC'=+ATXC D
.;process each complication
.S ATXR1=0 F S ATXR1=$O(^ACM(42.1,ATXC,"RG",ATXR1)) Q:ATXR1'=+ATXR1 D
..;process each register
..S ATXR=$P(^ACM(42.1,ATXC,"RG",ATXR1,0),U,1)
..Q:'$D(^ACM(41,"AC",ATXPD,ATXR)) ;patient not on this register
..S ATXRCMS=^ACM(41,"AC",ATXPD,ATXR)
..;update complication for this patient
..Q:$D(^ACM(42,"AC",ATXR,ATXPD,ATXC)) ;pt already has this complication
..;add complication to file
..S DIADD=1,DLAYGO=9002242,X=ATXC,DIC="^ACM(42,",DIC("DR")=".02////"_ATXPD_";.03////"_ATXRCMS_";.04////"_ATXR,DIC(0)="L" K DD,D0,DO D FILE^DICN
..K DIC,DIADD,DLAYGO
Q
ATXPOV ; IHS/OHPRD/TMJ - IF ICD CODE HAS A TAXON, ENTER PAT IN PT TAX FILE ; 07 Feb 2016 5:51 PM
+1 ;;5.1;TAXONOMY;**11,14,15**;FEB 04, 1997;Build 20
+2 ;IHS/TUCSON/LAB - because of the check for the variable
+3 ;IHS/CMI/LAB - patch 1 to version 5.1 allows the autoupdating
+4 ;of complications in a CMS register triggered from PCC Data Entry
+5 ;6/20/2000
+6 ;APCDDATE at the top of this routine, bulletins were not being
+7 ;sent if the user was not using PCC Data Entry. This has been
+8 ;changed so that bulletins will be fired even if the POV is
+9 ;created by a link from another package.
+10 ;Q:'$D(APCDDATE)!('$D(DA))!('$D(X))
+11 ;DA IS DA OF aupnvpov, X is internal of ICD code
IF '$DATA(DA)!('$DATA(X))
QUIT
+12 NEW ATXPOVDA,ATXDI,ATXICD
+13 ;ATXVISI visit ien
+14 ;ATXVIS visit date
+15 ;ATXDFN patient dfn
+16 ;ATXPOVDA V POV ien
+17 ;kill side of xref, .03 exists
+18 SET ATXPOVDA=DA
+19 ;ien of icd code
SET ATXDI=X
+20 ;I $P(^AUPNVPOV(ATXPOVDA,0),U,3) S ATXVISI=$P(^AUPNVPOV(ATXPOVDA,0),U,3),ATXVIS=$$VD^APCLV(ATXVISI),ATXDFN=$P(^AUPNVPOV(ATXPOVDA,0),U,2)
+21 ;I '$D(ATXAD),$P(^AUPNVPOV(DA,0),U,3) S ATXVIS=+^AUPNVSIT($P(^AUPNVPOV(DA,0),U,3),0) S:'$D(APCDVSIT) APCDVSIT=$P(^AUPNVPOV(DA,0),U,3) S:'$D(AUPNPAT) AUPNPAT=$P(^AUPNVPOV(DA,0),U,2)
+22 ;E S ATXVIS=$P(APCDDATE,".")
+23 ;Set ATXVIS with visit Date
+24 ;E S ATXVIS=$S($G(APCDDATE):$P(APCDDATE,"."),$G(APCDVSIT):$P($P(^AUPNVSIT(APCDVSIT,0),U),"."),1:"")
+25 ;Q:ATXVIS=""
+26 ;
+27 ;I '$O(^ICD9(ATXDI,9999999.41,0)) D CMSCMPL,EOJ Q ;IHS/CMI/LAB
+28 ;NEW FOR AICD 4.0
+29 ;loop "ABLT" and call ICD^ATXCHK with X
+30 NEW T,B,G,F
+31 SET (B,G)=0
FOR
SET B=$ORDER(^ATXAX("ABLT",B))
IF B'=+B!(G)
QUIT
Begin DoDot:1
+32 SET T=0
FOR
SET T=$ORDER(^ATXAX("ABLT",B,T))
IF T'=+T!(G)
QUIT
Begin DoDot:2
+33 IF '$DATA(^ATXAX(T,0))
QUIT
+34 IF $PIECE(^ATXAX(T,0),U,15)'=80
QUIT
+35 IF $$ICD^ATXCHK(ATXDI,T,9)
SET G=1
End DoDot:2
+36 QUIT
End DoDot:1
+37 IF 'G
DO CMSCMPL
QUIT
+38 ;IF NOT IN SET SIDE THEN JUST DO COMPLICATIONS ***LORI
IF '$DATA(ATXAD)
DO CMSCMPL
QUIT
+39 ;
+40 DO START
+41 DO EOJ
+42 QUIT
+43 ;
+44 ;
CALL ;SEE IF PT TAX FILE TO BE UPDATED
+1 IF '$DATA(^ATXPAT(ATXDT,0))#2
QUIT
+2 IF ATXVIS<$PIECE(^ATXAX(ATXDT,0),U,6)
QUIT
+3 IF $DATA(ATXAD)
DO DIEADD^ATXPAT
QUIT
+4 IF '$DATA(ATXAD)
DO DIEDEL^ATXPAT
QUIT
+5 QUIT
+6 ;
START ;
+1 ;
+2 NEW ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTDTH,ZTSK,%
+3 SET ATXICD=ATXDI
+4 FOR %="ATXPOVDA","ATXICD","ATXDI"
SET ZTSAVE(%)=""
+5 SET ZTRTN="START1^ATXPOV"
+6 SET ZTDESC="BULLETIN/COMPL TRIGGER FROM PCC DATA ENTRY"
+7 SET ZTIO=""
+8 ;CHANGE TO 300
SET ZTDTH=$HOROLOG
SET $PIECE(ZTDTH,",",2)=$PIECE(ZTDTH,",",2)+300
+9 DO ^%ZTLOAD
+10 KILL ZTSK
X QUIT
+1 ;
START1 ;EP = called from taskman
+1 ;call bulletin for any taxonomies that have this code
+2 SET ATXDT=""
+3 SET ATXB=0
FOR
SET ATXB=$ORDER(^ATXAX("ABLT",ATXB))
IF ATXB'=+ATXB
QUIT
Begin DoDot:1
+4 SET ATXT=0
FOR
SET ATXT=$ORDER(^ATXAX("ABLT",ATXB,ATXT))
IF ATXT'=+ATXT
QUIT
Begin DoDot:2
+5 SET ATXDT=""
IF $$ICD^ATXCHK(ATXDI,ATXT,9)
SET ATXDT=ATXT
DO EN^ATXBULL
End DoDot:2
+6 QUIT
End DoDot:1
+7 DO CMSCMPL0
+8 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
EOJ ;
+1 KILL ATXDT,ATXL,ATXPD,ATXDI,ATXAD,ATXVIS,ATXDOLH,ATXPOVDA,ATXVISDA,ATXC,ATXR,ATXRCMS,ATXR1
+2 QUIT
+3 ;
CMSCMPL ;
+1 ;if this ICD code is in ^ACM(42.1,"DX", xref
+2 ;then get registers associated with it
+3 ;if this patient is on any of those registers, then update
+4 ;their complication list if this isn't already on their list
+5 ;S ATXDT=0,ATXPD=AUPNPAT
+6 ;maybe this should be tasked to the background ??
+7 IF ATXDI=""
QUIT
+8 ;IHS/CMI/LAB - not in any complication list so don't bother
IF '$DATA(^ACM(42.1,"DX",ATXDI))
QUIT
+9 ;task off to taskman
+10 ;G CMSCMPL0 ;LORI REMOVE
+11 NEW ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,%
+12 FOR %="ATXDI","ATXPOVDA"
SET ZTSAVE(%)=""
+13 SET ZTRTN="CMSCMPL0^ATXPOV"
+14 SET ZTDESC="CMS COMPL TRIGGER FROM PCC DATA ENTRY"
+15 SET ZTIO=""
+16 SET ZTDTH=$HOROLOG
SET $PIECE(ZTDTH,",",2)=$PIECE(ZTDTH,",",2)+300
+17 DO ^%ZTLOAD
+18 KILL ZTSK
+19 QUIT
CMSCMPL0 ;EP - called from taskman
+1 ;SET UP VARS
+2 IF ATXDI=""
QUIT
+3 ;IHS/CMI/LAB - not in any complication list so don't bother
IF '$DATA(^ACM(42.1,"DX",ATXDI))
QUIT
+4 NEW ATXC,ATXR,ATXRA,ATXPD
+5 ;patient
SET ATXPD=$PIECE($GET(^AUPNVPOV(ATXPOVDA,0)),U,2)
+6 ;v pov must have been deleted
IF 'ATXPD
QUIT
+7 SET ATXC=0
FOR
SET ATXC=$ORDER(^ACM(42.1,"DX",ATXDI,ATXC))
IF ATXC'=+ATXC
QUIT
Begin DoDot:1
+8 ;process each complication
+9 SET ATXR1=0
FOR
SET ATXR1=$ORDER(^ACM(42.1,ATXC,"RG",ATXR1))
IF ATXR1'=+ATXR1
QUIT
Begin DoDot:2
+10 ;process each register
+11 SET ATXR=$PIECE(^ACM(42.1,ATXC,"RG",ATXR1,0),U,1)
+12 ;patient not on this register
IF '$DATA(^ACM(41,"AC",ATXPD,ATXR))
QUIT
+13 SET ATXRCMS=^ACM(41,"AC",ATXPD,ATXR)
+14 ;update complication for this patient
+15 ;pt already has this complication
IF $DATA(^ACM(42,"AC",ATXR,ATXPD,ATXC))
QUIT
+16 ;add complication to file
+17 SET DIADD=1
SET DLAYGO=9002242
SET X=ATXC
SET DIC="^ACM(42,"
SET DIC("DR")=".02////"_ATXPD_";.03////"_ATXRCMS_";.04////"_ATXR
SET DIC(0)="L"
KILL DD,D0,DO
DO FILE^DICN
+18 KILL DIC,DIADD,DLAYGO
End DoDot:2
End DoDot:1
+19 QUIT
