BTPWPFND ;VNGT/HS/ALA-Find Events for Tracking ; 22 Apr 2008 7:15 PM
;;1.2;CARE MANAGEMENT EVENT TRACKING;**1**;JUL 07,2017;Build 5
;
;
EN(JOB) ;EP - Entry point
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPFND D UNWIND^%ZTER"
NEW PRCN,TGLOB,USER,TMFRAME,TXN,ERROR
; Clean up superceded records
NEW STAT,DA,DIK
S STAT="S",DA="",DIK="^BTPWQ("
F S DA=$O(^BTPWQ("AC",STAT,DA)) Q:DA="" D ^DIK
;
S PRCN=0,TGLOB=$NA(^XTMP("BTPWPRC"))
S JOB=$G(JOB,"")
S USER=$S(JOB="Nightly":JOB_" ",1:"Initial ")_"job"
NEW BTPWUP
S BTPWUP(90628,"1,",.06)=$$NOW^XLFDT()
S BTPWUP(90508,"1,",24.11)=$G(ZTSK)
D FILE^DIE("","BTPWUP","ERROR")
K @TGLOB
S @TGLOB@(0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"CMET Find Events"
F S PRCN=$O(^BTPW(90621,PRCN)) Q:'PRCN D
. I $P(^BTPW(90621,PRCN,0),U,3)'="" Q
. S TXN=0
. F S TXN=$O(^BTPW(90621,PRCN,1,TXN)) Q:'TXN D
.. NEW DA,IENS,TAX,FRN,FREF,ORD,UID,TREF,GREF,MOD,FIELD,RFILE,MN,MCD,MDF,OPER,AN,MD
.. NEW TFILE
.. S DA(1)=PRCN,DA=TXN,IENS=$$IENS^DILF(.DA),ORD=1
.. S TAX=$$GET1^DIQ(90621.01,IENS,.01,"E")
.. S FRN=$$GET1^DIQ(90621.01,IENS,.03,"I")
.. I FRN'="" D
... NEW FILE,FIELD
... S FREF=$$GET1^DIQ(90621.1,FRN_",",.02,"I")
... S ORD=$$GET1^DIQ(90621.1,FRN_",",.05,"E")
... S FIELD=$$GET1^DIQ(90621.1,FRN_",",.03,"E")
... S TFILE=$$GET1^DIQ(90621.1,FRN_",",.08,"I")
... S RFILE=$$GET1^DID(FREF,FIELD,"","SPECIFIER"),RFILE=$$STRIP^XLFSTR(RFILE,"ABCDEFGHIJKLMNOPQRSTUVWXYZ*'")
.. ; Check for modifiers
.. I $O(^BTPW(90621,PRCN,1,TXN,1,0))'="" S MD=0 D
... F S MD=$O(^BTPW(90621,PRCN,1,TXN,1,MD)) Q:'MD D
.... S MCD=$P(^BTPW(90621,PRCN,1,TXN,1,MD,0),U,1),OPER=$P(^BTPW(90621,PRCN,1,TXN,1,MD,0),U,2)
.... S MDF=$O(^AUTTCMOD("B",MCD,""))
.... I MDF'="" S MOD(MDF)=OPER
.. ;
.. S UID=$J,TREF=$NA(^TMP("BQITAX",UID)),GREF=$$ROOT^DILFD(FREF,"",1)
.. K @TREF
.. S TYPE="" S:$G(TFILE)=60 TYPE="L"
.. D BLD^BQITUTL(TAX,TREF,TYPE)
.. ;
.. S TIEN=0 F S TIEN=$O(@TREF@(TIEN)) Q:'TIEN D
... S IEN=""
... F S IEN=$O(@GREF@("B",TIEN,IEN),-1) Q:IEN="" D
.... ; if a bad record (no zero node), quit
.... I $G(@GREF@(IEN,0))="" Q
.... ; get patient record
.... S DFN=$$GET1^DIQ(FREF,IEN,.02,"I") Q:DFN=""
.... I $P($G(^DPT(DFN,.35)),U,1)'="" Q
.... ;I '$$HRN^BQIUL1(DFN),'$$VTHR^BQIUL1(DFN) Q
.... I '$$HRN^BQIUL1(DFN) Q
.... ; get the visit information
.... S VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")\1 Q:VISIT=""
.... ; if the visit is deleted, quit
.... I $$GET1^DIQ(9000010,VISIT,.11,"I")=1 Q
.... ; if the visit has no dependents, quit
.... I $$GET1^DIQ(9000010,VISIT,.09,"I")=0 Q
.... S VSDTM=$P($G(^AUPNVSIT(VISIT,0)),U,1)\1 Q:VSDTM=0
.... Q:"DXCTI"[$P(^AUPNVSIT(VISIT,0),U,7)
.... I $D(MOD)>0 S QFL=0,MN=0 D Q:QFL
..... NEW BTJ
..... F S MN=$O(MOD(MN)) Q:MN="" D Q:QFL
...... S OPER=MOD(MN)
...... F BTJ=.08,.09 I $$GET1^DIQ(FREF,IEN,BTJ,"I")="" S QFL=2
...... F BTJ=.08,.09 I $$GET1^DIQ(FREF,IEN,BTJ,"I")=MN,OPER="E" S QFL=1
...... F BTJ=.08,.09 I $$GET1^DIQ(FREF,IEN,BTJ,"I")=MN,OPER="I" S QFL=0
.... S BTPWIEN=$O(^BWPCD("AD",VISIT,""))
.... I BTPWIEN'="",$P($G(^BWPCD(BTPWIEN,"PCC")),U,2)'=IEN S BTPWIEN=""
.... ; Check Mastectomy for bilateral, unilateral or unspecified
.... I PRCN=36,$D(@TGLOB@(DFN,25,VSDTM)) Q
.... I PRCN=46,$D(@TGLOB@(DFN,25,VSDTM))!($D(@TGLOB@(DFN,36,VSDTM))) Q
.... S @TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,IEN)=BTPWIEN_U_FREF_U_$P(^DIC(FREF,0),U,1)
;
S DFN=""
F S DFN=$O(@TGLOB@(DFN)) Q:DFN="" D
. S PIEN=""
. F S PIEN=$O(^BWPCD("C",DFN,PIEN)) Q:PIEN="" D
.. S PROC=$P(^BWPCD(PIEN,0),U,4)
.. S PRCN=$O(^BTPW(90621,"AP",PROC,"")) I PRCN="" S PRCN="~"
.. I PRCN'="~",$P(^BTPW(90621,PRCN,0),U,3)'="" Q
.. S PRCDTM=$P(^BWPCD(PIEN,0),U,3)
.. I PRCDTM="" S PRCDTM=$P(^BWPCD(PIEN,0),U,12)
.. S PRCDTM=PRCDTM\1,ORD=1
.. S FREF=$P(^BWPN(PROC,0),U,12),FILE="" I FREF'="" S FILE=$P(^DIC(FREF,0),U,1)
.. I FREF="" D
... I $P(^BWPCD(PIEN,0),U,15)'="" S FILE="V RADIOLOGY" Q
... I PROC=40 S FILE="V LAB"
.. I FREF'="" S FRN=$O(^BTPW(90621.1,"B",FILE,""))
.. I $G(FRN)'="" S ORD=$$GET1^DIQ(90621.1,FRN_",",.05,"E")
.. S VISIT=$P($G(^BWPCD(PIEN,"PCC")),U,1),IEN=$P($G(^BWPCD(PIEN,"PCC")),U,2)
.. I $$UP^XLFSTR($$GET1^DIQ(9002086.1,PIEN_",",.05,"E"))["ERROR" D Q
... S:VISIT="" VISIT="~" S:IEN="" IEN="~"
... ;I '$D(^BTPWQ("C",DFN,PRCN,VISIT,IEN,FRN)) Q
... I '$D(^BTPWQ("D",DFN,PRCN,VSDTM)) Q
... NEW QIEN,DA,DIK
... S QIEN=$O(^BTPWQ("C",DFN,PRCN,VISIT,IEN,FRN,"")) I QIEN="" Q
... I $P(^BTPWQ(QIEN,0),U,8)="P" S DA=QIEN,DIK="^BTPWQ(" D ^DIK
.. I IEN'="",$$GET1^DIQ(FREF,IEN_",",.03,"I")'=VISIT D
... S VISIT=$$GET1^DIQ(FREF,IEN_",",.03,"I")
... I $$GET1^DIQ(FREF,IEN_",",.01,"E")="" S IEN=""
.. S:VISIT="" VISIT="~" S:IEN="" IEN="~"
.. S @TGLOB@(DFN,PRCN,PRCDTM,ORD,VISIT,IEN,PROC)=PIEN_U_FREF_U_FILE
;
; Check against Radiology file
D RAD
;
STOR ; Store the records found
NEW DFN,BCT,BQARRAY
S DFN=0
F S DFN=$O(@TGLOB@(DFN)) Q:DFN="" D
. K BQARRAY
. D CHK(DFN,.BQARRAY)
. S BCT=""
. F S BCT=$O(BQARRAY(BCT)) Q:BCT="" D
.. NEW PRCN,TMFRAME,VSDTM,VISIT,RIEN,FREF,RARPT,WHIEN,FRIL,FREF,ACCN,ENDT
.. S PRCN=$P(BQARRAY(BCT),U,1)
.. S TMFRAME=$P($G(^BTPW(90621,PRCN,5)),U,4),ENDT=""
.. I TMFRAME'="" S TMFRAME="T-"_TMFRAME,ENDT=$$DATE^BQIUL1(TMFRAME)
.. S VSDTM=$P(BQARRAY(BCT),U,6)
.. S VISIT=$P(BQARRAY(BCT),U,2)
.. S RIEN=$P(BQARRAY(BCT),U,7)
.. S FREF=$P(BQARRAY(BCT),U,4)
.. S RARPT=$P(BQARRAY(BCT),U,8)
.. S WHIEN=$P(BQARRAY(BCT),U,3)
.. S FRIL="~"
.. I FREF'="" S FRIL=$O(^BTPW(90621.1,"C",FREF,""))
.. I FRIL="" S FREF=$P(BQARRAY(BCT),U,5) I FREF'="" S FRIL=$O(^BTPW(90621.1,"B",FREF,""))
.. ; Check for existence of the record already in the queue file
.. I DFN'="",PRCN'="",VSDTM'="",$D(^BTPWQ("D",DFN,PRCN,VSDTM)) Q
.. ;I DFN'="",PRCN'="",VISIT'="",RIEN'="",FRIL'="",$D(^BTPWQ("C",DFN,PRCN,VISIT,RIEN,FRIL)) Q
.. ;
.. I TMFRAME'="",VSDTM<ENDT Q
.. ;
.. ; Check if the visit has been merged to another visit
.. I $P($G(^AUPNVSIT(VISIT,0)),U,37)'="" S VISIT=$P($G(^AUPNVSIT(VISIT,0)),U,37),MVSDTM=$P($G(^AUPNVSIT(VISIT,0)),U,1)\1
.. I DFN'="",PRCN'="",$G(MVSDTM)'="",$D(^BTPWQ("D",DFN,PRCN,MVSDTM)) Q
.. I DFN'="",PRCN'="",VSDTM'="",$D(^BTPWQ("D",DFN,PRCN,VSDTM)) Q
.. ;I DFN'="",PRCN'="",VISIT'="",RIEN'="",FRIL'="",$D(^BTPWQ("C",DFN,PRCN,VISIT,RIEN,FRIL)) Q
.. ;
.. I FREF=9000010.09 D
... I RIEN'="~",RIEN'="" S ACCN=$P($G(^AUPNVLAB(RIEN,0)),U,6)
... I $G(ACCN)'="",$E(ACCN,1,2)="WH" S WHIEN=$O(^BPWCD("B",$E(ACCN,3,$L(ACCN)),"")) I WHIEN'="" S ACCN=""
.. ;
.. NEW DIC,DLAYGO,X,Y,IEN,BTPUPD,PXSEC
.. S DIC="^BTPWQ(",DIC(0)="LMNZ",DLAYGO=90629,DIC("P")=DLAYGO
.. S X=PRCN
.. K DO,DD D FILE^DICN
.. S IEN=+Y
.. S BTPUPD(90629,IEN_",",.02)=DFN,BTPUPD(90629,IEN_",",.03)=VSDTM
.. S BTPUPD(90629,IEN_",",.04)=VISIT,BTPUPD(90629,IEN_",",.05)=RIEN
.. S BTPUPD(90629,IEN_",",.06)=FRIL,BTPUPD(90629,IEN_",",.07)=$$NOW^XLFDT()
.. S BTPUPD(90629,IEN_",",.09)=WHIEN,BTPUPD(90629,IEN_",",.1)=RARPT
.. S BTPUPD(90629,IEN_",",.15)=$G(ACCN)
.. S BTPUPD(90629,IEN_",",.08)="P",BTPUPD(90629,IEN_",",.12)=USER
.. S BTPUPD(90629,IEN_",",.13)=$$CAT^BTPWPDSP(PRCN,1),BTPUPD(90629,IEN_",",.11)=$$NOW^XLFDT()
.. S BTPUPD(90629,IEN_",",.16)=$$GET1^DIQ(9000010,VISIT_",",.06,"I")
.. ;
.. K ACCN,WHIEN
.. ; Check for exceptions
.. S PSEX=$P($G(^BTPW(90621,PRCN,5)),U,1)
.. I PSEX'="" D
... I $P(^DPT(DFN,0),U,2)'=PSEX S BTPUPD(90629,IEN_",",.08)="E"
.. D FILE^DIE("","BTPUPD","ERROR")
.. ;I $D(ERROR) D ERR Q
.. ;
.. ; Check to supercede previously existing record
.. NEW PIEN,BTPUPD
.. S PIEN=""
.. F S PIEN=$O(^BTPWQ("AD",DFN,PIEN)) Q:PIEN="" D
... I $P(^BTPWQ(PIEN,0),U,1)'=PRCN Q
... I PIEN=IEN Q
... I $P(^BTPWQ(PIEN,0),U,8)="P" D
.... S BTPUPD(90629,PIEN_",",.08)="S"
.... D FILE^DIE("","BTPUPD","ERROR")
.. ;
.. ; Check for possible match with future followup
.. NEW TIEN
.. S TIEN=""
.. F S TIEN=$O(^BTPWP("AE",DFN,"F",TIEN)) Q:TIEN="" D
... I $P(^BTPWP(TIEN,0),U,1)'=PRCN Q
... S BTPUPD(90629,IEN_",",1.01)=TIEN
... D FILE^DIE("","BTPUPD","ERROR")
;
; Clean up events that could have been changed by a change in a taxonomy or other
NEW DFN,PIEN,EVNT,STAT,VDATE
S DFN=""
F S DFN=$O(^BTPWQ("AD",DFN)) Q:DFN="" D
. S PIEN=""
. F S PIEN=$O(^BTPWQ("AD",DFN,PIEN)) Q:PIEN="" D
.. S EVNT=$P(^BTPWQ(PIEN,0),U,1),STAT=$P(^(0),U,8),VDATE=$P(^(0),U,3)
.. ; If event exists for this patient, quit
.. I $D(^XTMP("BTPWPRC",DFN,EVNT,VDATE)) Q
.. ; if someone tracked the event, have to quit
.. I STAT="T" Q
.. ; delete queued record if not found
.. NEW DA,DIK
.. S DIK="^BTPWQ(",DA=PIEN D ^DIK
;
; Clean up merged visits
D ^BTPWPFNC
;
NEW BTPWUP
S BTPWUP(90628,"1,",.07)=$$NOW^XLFDT()
S BTPWUP(90508,"1,",24.11)="@"
D FILE^DIE("","BTPWUP","ERROR")
K BCT,BQARRAY,BTPWIEN,CT,DA,DFN,DIC,DLAYGO,FILE,FREF,FRIL,FRN,IEN
K ORD,PIEN,PRCDTM,PROC,PSEX,QFL,RADATA,RAIEN,RARPN,RARPT,RDIEN,RDTM
K RDTM,REF,RIEN,RPRCN,STAT,TAX,TIEN,VFL,VISIT,VSDTM,WHIEN,WIEN,X,Y
K @TREF,TREF
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
Q
;
CHK(DFN,ARRAY) ;EP - Take raw data for a patient and refine to one most recent procedure
S CT=0,TGLOB=$NA(^XTMP("BTPWPRC")) K ARRAY
S PRCN=""
F S PRCN=$O(@TGLOB@(DFN,PRCN)) Q:PRCN="" D
. I PRCN="~" Q
. K BWH,BREC
. S VSDTM=$O(@TGLOB@(DFN,PRCN,""),-1) Q:VSDTM="" D
.. S ORD=""
.. S ORD=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD)) Q:ORD="" D Q:'QFL
... S VISIT="",QFL=1
... F S VISIT=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT)) Q:VISIT="" D Q:'QFL
.... S RIEN="",STAT="",RARPT=""
.... F S RIEN=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN)) Q:RIEN="" D Q:'QFL
..... S WHIEN="",BREC(VSDTM)=RIEN
..... I $G(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))="" D
...... S WIEN=$O(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,""))
...... S WHIEN=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,1)
...... S REF=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,2,3)
...... S RARPT=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,4)
..... I $G(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))'="" D
...... S WHIEN=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,1)
...... S REF=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,2,3)
...... S RARPT=$P(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,4)
.... ;
.... I WHIEN'="" D
..... I VISIT'="~" Q
..... S BWH(VSDTM)=WHIEN
..... S STAT=$P(^BWPCD(WHIEN,0),U,14)
..... S RARPT=$P(^BWPCD(WHIEN,0),U,15)
..... I RARPT="" D Q
...... I VISIT="~" S VISIT=$P($G(^BWPCD(WHIEN,"PCC")),U,1),RIEN=$P($G(^BWPCD(WHIEN,"PCC")),U,2)
..... S RARPN=$O(^RARPT("B",RARPT,"")) I RARPN="" Q
..... I $P($G(^RARPT(RARPN,0)),U,2)'=$P($G(^BWPCD(WHIEN,0)),U,2) Q
..... S RDTM=0
..... F S RDTM=$O(^RADPT(DFN,"DT",RDTM)) Q:RDTM="AP"!(RDTM="") D
...... S RPRCN=0
...... F S RPRCN=$O(^RADPT(DFN,"DT",RDTM,"P",RPRCN)) Q:'RPRCN D
....... I $P($G(^RADPT(DFN,"DT",RDTM,"P",RPRCN,0)),U,17)'=RARPN Q
....... NEW DA,IENS
....... S DA(2)=DFN,DA(1)=RDTM,DA=RPRCN,IENS=$$IENS^DILF(.DA)
....... I $$GET1^DIQ(70.03,IENS,3,"E")="CANCELLED" Q
....... I $$GET1^DIQ(70.03,IENS,3,"E")="" Q
....... S VISIT=$P($G(^RADPT(DFN,"DT",RDTM,"P",RPRCN,"PCC")),U,3)
....... S RIEN=$P($G(^RADPT(DFN,"DT",RDTM,"P",RPRCN,"PCC")),U,2) I RIEN="" Q
....... I $G(^AUPNVRAD(RIEN,0))="" Q
....... I $P(^AUPNVRAD(RIEN,0),U,3)'=VISIT S VISIT=$P(^AUPNVRAD(RIEN,0),U,3)
.... I VISIT="" S QFL=1,VISIT="~" Q
.... I WHIEN="",$D(BWH(VSDTM)) S WHIEN=BWH(VSDTM) K BWH
.... I RIEN="",$D(BREC(VSDTM)) S RIEN=BREC(VSDTM) K BREC
.... S CT=CT+1,ARRAY(CT)=PRCN_U_VISIT_U_WHIEN_U_REF_U_VSDTM_U_RIEN_U_RARPT,QFL=0
Q
;
RAD ; Radiology procedures
; VFL is the reference for CPT files. Searching all CPT taxonomies against the RAD/NUC MED PROCEDURES for
; matching CPT codes.
;
S VFL=5,PRCN=""
F S PRCN=$O(^BTPW(90621,"AC",VFL,PRCN)) Q:PRCN="" D
. S PIEN=""
. F S PIEN=$O(^BTPW(90621,"AC",VFL,PRCN,PIEN)) Q:PIEN="" D
.. S TAX=$P(^BTPW(90621,PRCN,1,PIEN,0),"^",1)
.. S UID=$J,TREF=$NA(^TMP("BQITAX",UID))
.. K @TREF
.. D BLD^BQITUTL(TAX,TREF)
.. S TIEN=""
.. F S TIEN=$O(@TREF@(TIEN)) Q:TIEN="" D
... ; if the CPT code is not found in the RAD/NUC MED PROCEDURES file, quit
... I '$D(^RAMIS(71,"D",TIEN)) Q
... S RAIEN=""
... F S RAIEN=$O(^RAMIS(71,"D",TIEN,RAIEN)) Q:RAIEN="" D
.... ; For every radiology patient (since there is no specific cross-reference by procedure)
.... S DFN=0
.... F S DFN=$O(^RADPT(DFN)) Q:'DFN D
..... S RDTM=""
..... F S RDTM=$O(^RADPT(DFN,"DT","AP",RAIEN,RDTM)) Q:RDTM="" D
...... S RDIEN=""
...... F S RDIEN=$O(^RADPT(DFN,"DT","AP",RAIEN,RDTM,RDIEN)) Q:RDIEN="" D
....... S FRN=$O(^BTPW(90621.1,"B","V RADIOLOGY",""))
....... I FRN'="" S ORD=$$GET1^DIQ(90621.1,FRN_",",.05,"E")
....... S RADATA=$G(^RADPT(DFN,"DT",RDTM,"P",RDIEN,"PCC"))
....... NEW DA,IENS
....... S DA(2)=DFN,DA(1)=RDTM,DA=RDIEN,IENS=$$IENS^DILF(.DA)
....... I $$GET1^DIQ(70.03,IENS,3,"E")="CANCELLED" Q
....... I $$GET1^DIQ(70.03,IENS,3,"E")="" Q
....... S RARPN=$P($G(^RADPT(DFN,"DT",RDTM,"P",RDIEN,0)),U,17)
....... S RARPT="" I RARPN'="" S RARPT=$P(^RARPT(RARPN,0),U,1)
....... S PRCDTM=$P(RADATA,U,1)\1
....... S VISIT=$P(RADATA,U,3)
....... S IEN=$P(RADATA,U,2) I IEN="" Q
....... I $G(^AUPNVRAD(IEN,0))="" Q
....... I $P(^AUPNVRAD(IEN,0),U,3)'=VISIT S VISIT=$P(^AUPNVRAD(IEN,0),U,3)
....... S:VISIT="" VISIT="~" S:IEN="" IEN="~"
....... S @TGLOB@(DFN,PRCN,PRCDTM,ORD,VISIT,IEN)=U_"9000010.22"_U_"V RADIOLOGY"_U_RARPT
Q
BTPWPFND ;VNGT/HS/ALA-Find Events for Tracking ; 22 Apr 2008 7:15 PM
+1 ;;1.2;CARE MANAGEMENT EVENT TRACKING;**1**;JUL 07,2017;Build 5
+2 ;
+3 ;
EN(JOB) ;EP - Entry point
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPFND D UNWIND^%ZTER"
+2 NEW PRCN,TGLOB,USER,TMFRAME,TXN,ERROR
+3 ; Clean up superceded records
+4 NEW STAT,DA,DIK
+5 SET STAT="S"
SET DA=""
SET DIK="^BTPWQ("
+6 FOR
SET DA=$ORDER(^BTPWQ("AC",STAT,DA))
IF DA=""
QUIT
DO ^DIK
+7 ;
+8 SET PRCN=0
SET TGLOB=$NAME(^XTMP("BTPWPRC"))
+9 SET JOB=$GET(JOB,"")
+10 SET USER=$SELECT(JOB="Nightly":JOB_" ",1:"Initial ")_"job"
+11 NEW BTPWUP
+12 SET BTPWUP(90628,"1,",.06)=$$NOW^XLFDT()
+13 SET BTPWUP(90508,"1,",24.11)=$GET(ZTSK)
+14 DO FILE^DIE("","BTPWUP","ERROR")
+15 KILL @TGLOB
+16 SET @TGLOB@(0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"CMET Find Events"
+17 FOR
SET PRCN=$ORDER(^BTPW(90621,PRCN))
IF 'PRCN
QUIT
Begin DoDot:1
+18 IF $PIECE(^BTPW(90621,PRCN,0),U,3)'=""
QUIT
+19 SET TXN=0
+20 FOR
SET TXN=$ORDER(^BTPW(90621,PRCN,1,TXN))
IF 'TXN
QUIT
Begin DoDot:2
+21 NEW DA,IENS,TAX,FRN,FREF,ORD,UID,TREF,GREF,MOD,FIELD,RFILE,MN,MCD,MDF,OPER,AN,MD
+22 NEW TFILE
+23 SET DA(1)=PRCN
SET DA=TXN
SET IENS=$$IENS^DILF(.DA)
SET ORD=1
+24 SET TAX=$$GET1^DIQ(90621.01,IENS,.01,"E")
+25 SET FRN=$$GET1^DIQ(90621.01,IENS,.03,"I")
+26 IF FRN'=""
Begin DoDot:3
+27 NEW FILE,FIELD
+28 SET FREF=$$GET1^DIQ(90621.1,FRN_",",.02,"I")
+29 SET ORD=$$GET1^DIQ(90621.1,FRN_",",.05,"E")
+30 SET FIELD=$$GET1^DIQ(90621.1,FRN_",",.03,"E")
+31 SET TFILE=$$GET1^DIQ(90621.1,FRN_",",.08,"I")
+32 SET RFILE=$$GET1^DID(FREF,FIELD,"","SPECIFIER")
SET RFILE=$$STRIP^XLFSTR(RFILE,"ABCDEFGHIJKLMNOPQRSTUVWXYZ*'")
End DoDot:3
+33 ; Check for modifiers
+34 IF $ORDER(^BTPW(90621,PRCN,1,TXN,1,0))'=""
SET MD=0
Begin DoDot:3
+35 FOR
SET MD=$ORDER(^BTPW(90621,PRCN,1,TXN,1,MD))
IF 'MD
QUIT
Begin DoDot:4
+36 SET MCD=$PIECE(^BTPW(90621,PRCN,1,TXN,1,MD,0),U,1)
SET OPER=$PIECE(^BTPW(90621,PRCN,1,TXN,1,MD,0),U,2)
+37 SET MDF=$ORDER(^AUTTCMOD("B",MCD,""))
+38 IF MDF'=""
SET MOD(MDF)=OPER
End DoDot:4
End DoDot:3
+39 ;
+40 SET UID=$JOB
SET TREF=$NAME(^TMP("BQITAX",UID))
SET GREF=$$ROOT^DILFD(FREF,"",1)
+41 KILL @TREF
+42 SET TYPE=""
IF $GET(TFILE)=60
SET TYPE="L"
+43 DO BLD^BQITUTL(TAX,TREF,TYPE)
+44 ;
+45 SET TIEN=0
FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF 'TIEN
QUIT
Begin DoDot:3
+46 SET IEN=""
+47 FOR
SET IEN=$ORDER(@GREF@("B",TIEN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:4
+48 ; if a bad record (no zero node), quit
+49 IF $GET(@GREF@(IEN,0))=""
QUIT
+50 ; get patient record
+51 SET DFN=$$GET1^DIQ(FREF,IEN,.02,"I")
IF DFN=""
QUIT
+52 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+53 ;I '$$HRN^BQIUL1(DFN),'$$VTHR^BQIUL1(DFN) Q
+54 IF '$$HRN^BQIUL1(DFN)
QUIT
+55 ; get the visit information
+56 SET VISIT=$$GET1^DIQ(FREF,IEN,.03,"I")\1
IF VISIT=""
QUIT
+57 ; if the visit is deleted, quit
+58 IF $$GET1^DIQ(9000010,VISIT,.11,"I")=1
QUIT
+59 ; if the visit has no dependents, quit
+60 IF $$GET1^DIQ(9000010,VISIT,.09,"I")=0
QUIT
+61 SET VSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),U,1)\1
IF VSDTM=0
QUIT
+62 IF "DXCTI"[$PIECE(^AUPNVSIT(VISIT,0),U,7)
QUIT
+63 IF $DATA(MOD)>0
SET QFL=0
SET MN=0
Begin DoDot:5
+64 NEW BTJ
+65 FOR
SET MN=$ORDER(MOD(MN))
IF MN=""
QUIT
Begin DoDot:6
+66 SET OPER=MOD(MN)
+67 FOR BTJ=.08,.09
IF $$GET1^DIQ(FREF,IEN,BTJ,"I")=""
SET QFL=2
+68 FOR BTJ=.08,.09
IF $$GET1^DIQ(FREF,IEN,BTJ,"I")=MN
IF OPER="E"
SET QFL=1
+69 FOR BTJ=.08,.09
IF $$GET1^DIQ(FREF,IEN,BTJ,"I")=MN
IF OPER="I"
SET QFL=0
End DoDot:6
IF QFL
QUIT
End DoDot:5
IF QFL
QUIT
+70 SET BTPWIEN=$ORDER(^BWPCD("AD",VISIT,""))
+71 IF BTPWIEN'=""
IF $PIECE($GET(^BWPCD(BTPWIEN,"PCC")),U,2)'=IEN
SET BTPWIEN=""
+72 ; Check Mastectomy for bilateral, unilateral or unspecified
+73 IF PRCN=36
IF $DATA(@TGLOB@(DFN,25,VSDTM))
QUIT
+74 IF PRCN=46
IF $DATA(@TGLOB@(DFN,25,VSDTM))!($DATA(@TGLOB@(DFN,36,VSDTM)))
QUIT
+75 SET @TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,IEN)=BTPWIEN_U_FREF_U_$PIECE(^DIC(FREF,0),U,1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+76 ;
+77 SET DFN=""
+78 FOR
SET DFN=$ORDER(@TGLOB@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+79 SET PIEN=""
+80 FOR
SET PIEN=$ORDER(^BWPCD("C",DFN,PIEN))
IF PIEN=""
QUIT
Begin DoDot:2
+81 SET PROC=$PIECE(^BWPCD(PIEN,0),U,4)
+82 SET PRCN=$ORDER(^BTPW(90621,"AP",PROC,""))
IF PRCN=""
SET PRCN="~"
+83 IF PRCN'="~"
IF $PIECE(^BTPW(90621,PRCN,0),U,3)'=""
QUIT
+84 SET PRCDTM=$PIECE(^BWPCD(PIEN,0),U,3)
+85 IF PRCDTM=""
SET PRCDTM=$PIECE(^BWPCD(PIEN,0),U,12)
+86 SET PRCDTM=PRCDTM\1
SET ORD=1
+87 SET FREF=$PIECE(^BWPN(PROC,0),U,12)
SET FILE=""
IF FREF'=""
SET FILE=$PIECE(^DIC(FREF,0),U,1)
+88 IF FREF=""
Begin DoDot:3
+89 IF $PIECE(^BWPCD(PIEN,0),U,15)'=""
SET FILE="V RADIOLOGY"
QUIT
+90 IF PROC=40
SET FILE="V LAB"
End DoDot:3
+91 IF FREF'=""
SET FRN=$ORDER(^BTPW(90621.1,"B",FILE,""))
+92 IF $GET(FRN)'=""
SET ORD=$$GET1^DIQ(90621.1,FRN_",",.05,"E")
+93 SET VISIT=$PIECE($GET(^BWPCD(PIEN,"PCC")),U,1)
SET IEN=$PIECE($GET(^BWPCD(PIEN,"PCC")),U,2)
+94 IF $$UP^XLFSTR($$GET1^DIQ(9002086.1,PIEN_",",.05,"E"))["ERROR"
Begin DoDot:3
+95 IF VISIT=""
SET VISIT="~"
IF IEN=""
SET IEN="~"
+96 ;I '$D(^BTPWQ("C",DFN,PRCN,VISIT,IEN,FRN)) Q
+97 IF '$DATA(^BTPWQ("D",DFN,PRCN,VSDTM))
QUIT
+98 NEW QIEN,DA,DIK
+99 SET QIEN=$ORDER(^BTPWQ("C",DFN,PRCN,VISIT,IEN,FRN,""))
IF QIEN=""
QUIT
+100 IF $PIECE(^BTPWQ(QIEN,0),U,8)="P"
SET DA=QIEN
SET DIK="^BTPWQ("
DO ^DIK
End DoDot:3
QUIT
+101 IF IEN'=""
IF $$GET1^DIQ(FREF,IEN_",",.03,"I")'=VISIT
Begin DoDot:3
+102 SET VISIT=$$GET1^DIQ(FREF,IEN_",",.03,"I")
+103 IF $$GET1^DIQ(FREF,IEN_",",.01,"E")=""
SET IEN=""
End DoDot:3
+104 IF VISIT=""
SET VISIT="~"
IF IEN=""
SET IEN="~"
+105 SET @TGLOB@(DFN,PRCN,PRCDTM,ORD,VISIT,IEN,PROC)=PIEN_U_FREF_U_FILE
End DoDot:2
End DoDot:1
+106 ;
+107 ; Check against Radiology file
+108 DO RAD
+109 ;
STOR ; Store the records found
+1 NEW DFN,BCT,BQARRAY
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(@TGLOB@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+4 KILL BQARRAY
+5 DO CHK(DFN,.BQARRAY)
+6 SET BCT=""
+7 FOR
SET BCT=$ORDER(BQARRAY(BCT))
IF BCT=""
QUIT
Begin DoDot:2
+8 NEW PRCN,TMFRAME,VSDTM,VISIT,RIEN,FREF,RARPT,WHIEN,FRIL,FREF,ACCN,ENDT
+9 SET PRCN=$PIECE(BQARRAY(BCT),U,1)
+10 SET TMFRAME=$PIECE($GET(^BTPW(90621,PRCN,5)),U,4)
SET ENDT=""
+11 IF TMFRAME'=""
SET TMFRAME="T-"_TMFRAME
SET ENDT=$$DATE^BQIUL1(TMFRAME)
+12 SET VSDTM=$PIECE(BQARRAY(BCT),U,6)
+13 SET VISIT=$PIECE(BQARRAY(BCT),U,2)
+14 SET RIEN=$PIECE(BQARRAY(BCT),U,7)
+15 SET FREF=$PIECE(BQARRAY(BCT),U,4)
+16 SET RARPT=$PIECE(BQARRAY(BCT),U,8)
+17 SET WHIEN=$PIECE(BQARRAY(BCT),U,3)
+18 SET FRIL="~"
+19 IF FREF'=""
SET FRIL=$ORDER(^BTPW(90621.1,"C",FREF,""))
+20 IF FRIL=""
SET FREF=$PIECE(BQARRAY(BCT),U,5)
IF FREF'=""
SET FRIL=$ORDER(^BTPW(90621.1,"B",FREF,""))
+21 ; Check for existence of the record already in the queue file
+22 IF DFN'=""
IF PRCN'=""
IF VSDTM'=""
IF $DATA(^BTPWQ("D",DFN,PRCN,VSDTM))
QUIT
+23 ;I DFN'="",PRCN'="",VISIT'="",RIEN'="",FRIL'="",$D(^BTPWQ("C",DFN,PRCN,VISIT,RIEN,FRIL)) Q
+24 ;
+25 IF TMFRAME'=""
IF VSDTM<ENDT
QUIT
+26 ;
+27 ; Check if the visit has been merged to another visit
+28 IF $PIECE($GET(^AUPNVSIT(VISIT,0)),U,37)'=""
SET VISIT=$PIECE($GET(^AUPNVSIT(VISIT,0)),U,37)
SET MVSDTM=$PIECE($GET(^AUPNVSIT(VISIT,0)),U,1)\1
+29 IF DFN'=""
IF PRCN'=""
IF $GET(MVSDTM)'=""
IF $DATA(^BTPWQ("D",DFN,PRCN,MVSDTM))
QUIT
+30 IF DFN'=""
IF PRCN'=""
IF VSDTM'=""
IF $DATA(^BTPWQ("D",DFN,PRCN,VSDTM))
QUIT
+31 ;I DFN'="",PRCN'="",VISIT'="",RIEN'="",FRIL'="",$D(^BTPWQ("C",DFN,PRCN,VISIT,RIEN,FRIL)) Q
+32 ;
+33 IF FREF=9000010.09
Begin DoDot:3
+34 IF RIEN'="~"
IF RIEN'=""
SET ACCN=$PIECE($GET(^AUPNVLAB(RIEN,0)),U,6)
+35 IF $GET(ACCN)'=""
IF $EXTRACT(ACCN,1,2)="WH"
SET WHIEN=$ORDER(^BPWCD("B",$EXTRACT(ACCN,3,$LENGTH(ACCN)),""))
IF WHIEN'=""
SET ACCN=""
End DoDot:3
+36 ;
+37 NEW DIC,DLAYGO,X,Y,IEN,BTPUPD,PXSEC
+38 SET DIC="^BTPWQ("
SET DIC(0)="LMNZ"
SET DLAYGO=90629
SET DIC("P")=DLAYGO
+39 SET X=PRCN
+40 KILL DO,DD
DO FILE^DICN
+41 SET IEN=+Y
+42 SET BTPUPD(90629,IEN_",",.02)=DFN
SET BTPUPD(90629,IEN_",",.03)=VSDTM
+43 SET BTPUPD(90629,IEN_",",.04)=VISIT
SET BTPUPD(90629,IEN_",",.05)=RIEN
+44 SET BTPUPD(90629,IEN_",",.06)=FRIL
SET BTPUPD(90629,IEN_",",.07)=$$NOW^XLFDT()
+45 SET BTPUPD(90629,IEN_",",.09)=WHIEN
SET BTPUPD(90629,IEN_",",.1)=RARPT
+46 SET BTPUPD(90629,IEN_",",.15)=$GET(ACCN)
+47 SET BTPUPD(90629,IEN_",",.08)="P"
SET BTPUPD(90629,IEN_",",.12)=USER
+48 SET BTPUPD(90629,IEN_",",.13)=$$CAT^BTPWPDSP(PRCN,1)
SET BTPUPD(90629,IEN_",",.11)=$$NOW^XLFDT()
+49 SET BTPUPD(90629,IEN_",",.16)=$$GET1^DIQ(9000010,VISIT_",",.06,"I")
+50 ;
+51 KILL ACCN,WHIEN
+52 ; Check for exceptions
+53 SET PSEX=$PIECE($GET(^BTPW(90621,PRCN,5)),U,1)
+54 IF PSEX'=""
Begin DoDot:3
+55 IF $PIECE(^DPT(DFN,0),U,2)'=PSEX
SET BTPUPD(90629,IEN_",",.08)="E"
End DoDot:3
+56 DO FILE^DIE("","BTPUPD","ERROR")
+57 ;I $D(ERROR) D ERR Q
+58 ;
+59 ; Check to supercede previously existing record
+60 NEW PIEN,BTPUPD
+61 SET PIEN=""
+62 FOR
SET PIEN=$ORDER(^BTPWQ("AD",DFN,PIEN))
IF PIEN=""
QUIT
Begin DoDot:3
+63 IF $PIECE(^BTPWQ(PIEN,0),U,1)'=PRCN
QUIT
+64 IF PIEN=IEN
QUIT
+65 IF $PIECE(^BTPWQ(PIEN,0),U,8)="P"
Begin DoDot:4
+66 SET BTPUPD(90629,PIEN_",",.08)="S"
+67 DO FILE^DIE("","BTPUPD","ERROR")
End DoDot:4
End DoDot:3
+68 ;
+69 ; Check for possible match with future followup
+70 NEW TIEN
+71 SET TIEN=""
+72 FOR
SET TIEN=$ORDER(^BTPWP("AE",DFN,"F",TIEN))
IF TIEN=""
QUIT
Begin DoDot:3
+73 IF $PIECE(^BTPWP(TIEN,0),U,1)'=PRCN
QUIT
+74 SET BTPUPD(90629,IEN_",",1.01)=TIEN
+75 DO FILE^DIE("","BTPUPD","ERROR")
End DoDot:3
End DoDot:2
End DoDot:1
+76 ;
+77 ; Clean up events that could have been changed by a change in a taxonomy or other
+78 NEW DFN,PIEN,EVNT,STAT,VDATE
+79 SET DFN=""
+80 FOR
SET DFN=$ORDER(^BTPWQ("AD",DFN))
IF DFN=""
QUIT
Begin DoDot:1
+81 SET PIEN=""
+82 FOR
SET PIEN=$ORDER(^BTPWQ("AD",DFN,PIEN))
IF PIEN=""
QUIT
Begin DoDot:2
+83 SET EVNT=$PIECE(^BTPWQ(PIEN,0),U,1)
SET STAT=$PIECE(^(0),U,8)
SET VDATE=$PIECE(^(0),U,3)
+84 ; If event exists for this patient, quit
+85 IF $DATA(^XTMP("BTPWPRC",DFN,EVNT,VDATE))
QUIT
+86 ; if someone tracked the event, have to quit
+87 IF STAT="T"
QUIT
+88 ; delete queued record if not found
+89 NEW DA,DIK
+90 SET DIK="^BTPWQ("
SET DA=PIEN
DO ^DIK
End DoDot:2
End DoDot:1
+91 ;
+92 ; Clean up merged visits
+93 DO ^BTPWPFNC
+94 ;
+95 NEW BTPWUP
+96 SET BTPWUP(90628,"1,",.07)=$$NOW^XLFDT()
+97 SET BTPWUP(90508,"1,",24.11)="@"
+98 DO FILE^DIE("","BTPWUP","ERROR")
+99 KILL BCT,BQARRAY,BTPWIEN,CT,DA,DFN,DIC,DLAYGO,FILE,FREF,FRIL,FRN,IEN
+100 KILL ORD,PIEN,PRCDTM,PROC,PSEX,QFL,RADATA,RAIEN,RARPN,RARPT,RDIEN,RDTM
+101 KILL RDTM,REF,RIEN,RPRCN,STAT,TAX,TIEN,VFL,VISIT,VSDTM,WHIEN,WIEN,X,Y
+102 KILL @TREF,TREF
+103 QUIT
+104 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 QUIT
+6 ;
CHK(DFN,ARRAY) ;EP - Take raw data for a patient and refine to one most recent procedure
+1 SET CT=0
SET TGLOB=$NAME(^XTMP("BTPWPRC"))
KILL ARRAY
+2 SET PRCN=""
+3 FOR
SET PRCN=$ORDER(@TGLOB@(DFN,PRCN))
IF PRCN=""
QUIT
Begin DoDot:1
+4 IF PRCN="~"
QUIT
+5 KILL BWH,BREC
+6 SET VSDTM=$ORDER(@TGLOB@(DFN,PRCN,""),-1)
IF VSDTM=""
QUIT
Begin DoDot:2
+7 SET ORD=""
+8 SET ORD=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD))
IF ORD=""
QUIT
Begin DoDot:3
+9 SET VISIT=""
SET QFL=1
+10 FOR
SET VISIT=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT))
IF VISIT=""
QUIT
Begin DoDot:4
+11 SET RIEN=""
SET STAT=""
SET RARPT=""
+12 FOR
SET RIEN=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))
IF RIEN=""
QUIT
Begin DoDot:5
+13 SET WHIEN=""
SET BREC(VSDTM)=RIEN
+14 IF $GET(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))=""
Begin DoDot:6
+15 SET WIEN=$ORDER(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,""))
+16 SET WHIEN=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,1)
+17 SET REF=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,2,3)
+18 SET RARPT=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN,WIEN),U,4)
End DoDot:6
+19 IF $GET(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN))'=""
Begin DoDot:6
+20 SET WHIEN=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,1)
+21 SET REF=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,2,3)
+22 SET RARPT=$PIECE(@TGLOB@(DFN,PRCN,VSDTM,ORD,VISIT,RIEN),U,4)
End DoDot:6
End DoDot:5
IF 'QFL
QUIT
+23 ;
+24 IF WHIEN'=""
Begin DoDot:5
+25 IF VISIT'="~"
QUIT
+26 SET BWH(VSDTM)=WHIEN
+27 SET STAT=$PIECE(^BWPCD(WHIEN,0),U,14)
+28 SET RARPT=$PIECE(^BWPCD(WHIEN,0),U,15)
+29 IF RARPT=""
Begin DoDot:6
+30 IF VISIT="~"
SET VISIT=$PIECE($GET(^BWPCD(WHIEN,"PCC")),U,1)
SET RIEN=$PIECE($GET(^BWPCD(WHIEN,"PCC")),U,2)
End DoDot:6
QUIT
+31 SET RARPN=$ORDER(^RARPT("B",RARPT,""))
IF RARPN=""
QUIT
+32 IF $PIECE($GET(^RARPT(RARPN,0)),U,2)'=$PIECE($GET(^BWPCD(WHIEN,0)),U,2)
QUIT
+33 SET RDTM=0
+34 FOR
SET RDTM=$ORDER(^RADPT(DFN,"DT",RDTM))
IF RDTM="AP"!(RDTM="")
QUIT
Begin DoDot:6
+35 SET RPRCN=0
+36 FOR
SET RPRCN=$ORDER(^RADPT(DFN,"DT",RDTM,"P",RPRCN))
IF 'RPRCN
QUIT
Begin DoDot:7
+37 IF $PIECE($GET(^RADPT(DFN,"DT",RDTM,"P",RPRCN,0)),U,17)'=RARPN
QUIT
+38 NEW DA,IENS
+39 SET DA(2)=DFN
SET DA(1)=RDTM
SET DA=RPRCN
SET IENS=$$IENS^DILF(.DA)
+40 IF $$GET1^DIQ(70.03,IENS,3,"E")="CANCELLED"
QUIT
+41 IF $$GET1^DIQ(70.03,IENS,3,"E")=""
QUIT
+42 SET VISIT=$PIECE($GET(^RADPT(DFN,"DT",RDTM,"P",RPRCN,"PCC")),U,3)
+43 SET RIEN=$PIECE($GET(^RADPT(DFN,"DT",RDTM,"P",RPRCN,"PCC")),U,2)
IF RIEN=""
QUIT
+44 IF $GET(^AUPNVRAD(RIEN,0))=""
QUIT
+45 IF $PIECE(^AUPNVRAD(RIEN,0),U,3)'=VISIT
SET VISIT=$PIECE(^AUPNVRAD(RIEN,0),U,3)
End DoDot:7
End DoDot:6
End DoDot:5
+46 IF VISIT=""
SET QFL=1
SET VISIT="~"
QUIT
+47 IF WHIEN=""
IF $DATA(BWH(VSDTM))
SET WHIEN=BWH(VSDTM)
KILL BWH
+48 IF RIEN=""
IF $DATA(BREC(VSDTM))
SET RIEN=BREC(VSDTM)
KILL BREC
+49 SET CT=CT+1
SET ARRAY(CT)=PRCN_U_VISIT_U_WHIEN_U_REF_U_VSDTM_U_RIEN_U_RARPT
SET QFL=0
End DoDot:4
IF 'QFL
QUIT
End DoDot:3
IF 'QFL
QUIT
End DoDot:2
End DoDot:1
+50 QUIT
+51 ;
RAD ; Radiology procedures
+1 ; VFL is the reference for CPT files. Searching all CPT taxonomies against the RAD/NUC MED PROCEDURES for
+2 ; matching CPT codes.
+3 ;
+4 SET VFL=5
SET PRCN=""
+5 FOR
SET PRCN=$ORDER(^BTPW(90621,"AC",VFL,PRCN))
IF PRCN=""
QUIT
Begin DoDot:1
+6 SET PIEN=""
+7 FOR
SET PIEN=$ORDER(^BTPW(90621,"AC",VFL,PRCN,PIEN))
IF PIEN=""
QUIT
Begin DoDot:2
+8 SET TAX=$PIECE(^BTPW(90621,PRCN,1,PIEN,0),"^",1)
+9 SET UID=$JOB
SET TREF=$NAME(^TMP("BQITAX",UID))
+10 KILL @TREF
+11 DO BLD^BQITUTL(TAX,TREF)
+12 SET TIEN=""
+13 FOR
SET TIEN=$ORDER(@TREF@(TIEN))
IF TIEN=""
QUIT
Begin DoDot:3
+14 ; if the CPT code is not found in the RAD/NUC MED PROCEDURES file, quit
+15 IF '$DATA(^RAMIS(71,"D",TIEN))
QUIT
+16 SET RAIEN=""
+17 FOR
SET RAIEN=$ORDER(^RAMIS(71,"D",TIEN,RAIEN))
IF RAIEN=""
QUIT
Begin DoDot:4
+18 ; For every radiology patient (since there is no specific cross-reference by procedure)
+19 SET DFN=0
+20 FOR
SET DFN=$ORDER(^RADPT(DFN))
IF 'DFN
QUIT
Begin DoDot:5
+21 SET RDTM=""
+22 FOR
SET RDTM=$ORDER(^RADPT(DFN,"DT","AP",RAIEN,RDTM))
IF RDTM=""
QUIT
Begin DoDot:6
+23 SET RDIEN=""
+24 FOR
SET RDIEN=$ORDER(^RADPT(DFN,"DT","AP",RAIEN,RDTM,RDIEN))
IF RDIEN=""
QUIT
Begin DoDot:7
+25 SET FRN=$ORDER(^BTPW(90621.1,"B","V RADIOLOGY",""))
+26 IF FRN'=""
SET ORD=$$GET1^DIQ(90621.1,FRN_",",.05,"E")
+27 SET RADATA=$GET(^RADPT(DFN,"DT",RDTM,"P",RDIEN,"PCC"))
+28 NEW DA,IENS
+29 SET DA(2)=DFN
SET DA(1)=RDTM
SET DA=RDIEN
SET IENS=$$IENS^DILF(.DA)
+30 IF $$GET1^DIQ(70.03,IENS,3,"E")="CANCELLED"
QUIT
+31 IF $$GET1^DIQ(70.03,IENS,3,"E")=""
QUIT
+32 SET RARPN=$PIECE($GET(^RADPT(DFN,"DT",RDTM,"P",RDIEN,0)),U,17)
+33 SET RARPT=""
IF RARPN'=""
SET RARPT=$PIECE(^RARPT(RARPN,0),U,1)
+34 SET PRCDTM=$PIECE(RADATA,U,1)\1
+35 SET VISIT=$PIECE(RADATA,U,3)
+36 SET IEN=$PIECE(RADATA,U,2)
IF IEN=""
QUIT
+37 IF $GET(^AUPNVRAD(IEN,0))=""
QUIT
+38 IF $PIECE(^AUPNVRAD(IEN,0),U,3)'=VISIT
SET VISIT=$PIECE(^AUPNVRAD(IEN,0),U,3)
+39 IF VISIT=""
SET VISIT="~"
IF IEN=""
SET IEN="~"
+40 SET @TGLOB@(DFN,PRCN,PRCDTM,ORD,VISIT,IEN)=U_"9000010.22"_U_"V RADIOLOGY"_U_RARPT
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 QUIT
