APCDK ; IHS/CMI/LAB - NIGHTLY AMBULATORY VISIT V FILE RELINKER ; 15 Nov 2010 12:10 PM
;;2.0;IHS PCC SUITE;**1,5,10**;MAY 14, 2009;Build 88
;
;
EN ;
D ^APCDCHKJ ;run in hospital re-linker to link I's to H's
D ^APCDKDTC ;dtc re-linker
S X1=DT,X2=-91 D C^%DTC S APCDK("DATE")=X_.999999
S U="^",(APCDK("VISITS"),APCDK("RELINK"))=0,APCDRUND=DT
;go through B index and get all visits since 61 days ago
S APCDKVD=APCDK("DATE") F S APCDKVD=$O(^AUPNVSIT("B",APCDKVD)) Q:APCDKVD'=+APCDKVD D
.S APCDKV=0 F S APCDKV=$O(^AUPNVSIT("B",APCDKVD,APCDKV)) Q:APCDKV'=+APCDKV D PROCESS
K APCDKVD
D EOJ
Q
EOJ ;
S DA=1,DIE="^AUTTSITE(",DR=".24////^S X=DT" D ^DIE K DA,DIE,DR
;update rpms site file, no error checking
S:$D(ZTQUEUED) ZTREQ="@"
K APCDKV,APCDKNV,APCDKMM,APCDKVFL,APCDKVDG,APCDKIGR,APCDVDFN,APCDK12N,APCDK,APCDKX,APCDKDSP,APCDKHI,APCDKPAT,APCDKAVD,APCDKAVC,APCDKVCT,APCDKDVR,APCDRUND
K DIE,DA,DR,DIU,DIV,DIC
Q
;
PROCESS ;Get vars and process visit
Q:'$D(^AUPNVSIT(APCDKV))
Q:$P(^AUPNVSIT(APCDKV,0),U,11)
S DFN=$P(^AUPNVSIT(APCDKV,0),U,5) I DFN="",$P(^AUPNVSIT(APCDKV,0),U,2)]"",$P(^AUPNVSIT(APCDKV,0),U,2)'=DT,$$NOVFILES(APCDKV) S DA=APCDKV,DIK="^AUPNVSIT(" D ^DIK Q ;delete visits with no patient
Q:'$P(^AUPNVSIT(APCDKV,0),U,9)
I $$GET1^DIQ(9009080,DFN,"1.1","I")=APCDKV Q ;Quit if current ER patient
I "AORSX"'[$P(^AUPNVSIT(APCDKV,0),U,7) Q ;only review ambulatory visits
Q:$D(^AUPNVPOV("AD",APCDKV)) ;leave complete visit alone
Q:$D(^AUPNVPRV("AD",APCDKV)) ;leave complete visit alone
S DFN=$P(^AUPNVSIT(APCDKV,0),U,5)
GVISITS ;go through all A and X visits on this date for this patient
S APCDKXVS=0,(APCDKAVD,APCDKAVC)=9999999-$P($P(^AUPNVSIT(APCDKV,0),U),"."),APCDKAVD=(APCDKAVD-1)_".9999999"
F S APCDKAVD=$O(^AUPNVSIT("AA",DFN,APCDKAVD)) Q:APCDKAVD="" Q:$P(APCDKAVD,".")'=APCDKAVC D
.F APCDKXVS=0:0 S APCDKXVS=$O(^AUPNVSIT("AA",DFN,APCDKAVD,APCDKXVS)) Q:APCDKXVS="" D D CHECKV
..Q:APCDKV=APCDKXVS ;don't compare to self
..Q:$P(^AUPNVSIT(APCDKXVS,0),U,11)
..Q:'$D(^AUPNVPOV("AD",APCDKXVS)) ;do not use incomplete visits to link to
..Q:'$D(^AUPNVPRV("AD",APCDKXVS)) ;quit if not a complete visit
..Q:$P(^AUPNVSIT(APCDKXVS,0),U,6)'=$P(^AUPNVSIT(APCDKV,0),U,6) ;don't use visits with differing facilities
..Q:"AORSX"'[$P(^AUPNVSIT(APCDKXVS,0),U,7) ;link to ambulatory only
..NEW X,P,S S (S,X)=0,APCDKDSP="" F S X=$O(^AUPNVPRV("AD",APCDKXVS,X)) Q:X'=+X S:$P(^AUPNVPRV(X,0),U,4)="P" APCDKDPP=+^(0) I $P(^(0),U,4)="S"!($P(^(0),U,4)="") S S=S+1,$P(APCDKDSP,U,S)=+^(0)
..S APCDKVFL=9000010 F S APCDKVFL=$O(^DIC(APCDKVFL)) Q:APCDKVFL>9000010.99!(APCDKVFL'=+APCDKVFL) D VENTRIES
..;go through all V file entries
.Q
Q
VENTRIES ;
S APCDKVDG=^DIC(APCDKVFL,0,"GL"),APCDKIGR=APCDKVDG_"""AD"",APCDKV,APCDVDFN)"
S APCDVDFN="" F APCDVI=1:1 S APCDVDFN=$O(@APCDKIGR) Q:APCDVDFN="" D CHECK
Q
;
CHECK ;
S APCDK12N=APCDKVDG_APCDVDFN_",12)"
Q:'$D(@(APCDK12N))
S APCDK12N=@(APCDK12N)
Q:APCDK12N=""
ENCPROV ;
;if both v record encounter provider and any provider in V Provider for this visit match, re-link and quit (both must have a value)
;G ORDPROV ;IHS/ANMC/LAB - 9/23/98 per Chris Saddler ;IHS/CMI/LAB
I APCDKVFL'=9000010.28,APCDKVFL'=9000010.11 G ORDPROV ;IHS/CMI/LAB for V NOTE
S APCDKVFP=""
G:$P(APCDK12N,U,4)="" ORDPROV
I $P(^DD(9000010.06,.01,0),U,2)[6,$P(^DD(APCDKVFL,1204,0),U,2)[200 S APCDKVFP=$P(^VA(200,$P(APCDK12N,U,4),0),U,16)
I $P(^DD(9000010.06,.01,0),U,2)[200,$P(^DD(APCDKVFL,1204,0),U,2)[200 S APCDKVFP=$P(APCDK12N,U,4)
I $P(^DD(9000010.06,.01,0),U,2)[6,$P(^DD(APCDKVFL,1204,0),U,2)[6 S APCDKVFP=$P(APCDK12N,U,4)
I APCDKVFP="" G ORDPROV
I $G(APCDKDPP)=APCDKVFP D RELINK Q
S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I APCDKVFP=X D RELINK Q
;I $G(APCDKDPP)=$P(APCDK12N,U,4) D RELINK Q
;S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I $P(APCDK12N,U,4)=X D RELINK Q
ORDPROV ;
S APCDKVFP=""
G:$P(APCDK12N,U,2)="" CLIN
I $P(^DD(9000010.06,.01,0),U,2)[6,$P(^DD(APCDKVFL,1202,0),U,2)[200 S APCDKVFP=$P(^VA(200,$P(APCDK12N,U,2),0),U,16)
I $P(^DD(9000010.06,.01,0),U,2)[200,$P(^DD(APCDKVFL,1202,0),U,2)[200 S APCDKVFP=$P(APCDK12N,U,2)
I $P(^DD(9000010.06,.01,0),U,2)[6,$P(^DD(APCDKVFL,1202,0),U,2)[6 S APCDKVFP=$P(APCDK12N,U,2)
I APCDKVFP="" G CLIN
I $G(APCDKDPP)=APCDKVFP D RELINK Q
S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I APCDKVFP=X D RELINK Q
;G:$P(APCDK12N,U,2)="" CLIN
;I $G(APCDKDPP)=$P(APCDK12N,U,2) D RELINK Q
;S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I $P(APCDK12N,U,2)=X D RELINK Q
CLIN ;check clinic
;Q ;per discussion with Linda ;IHS/CMI/LAB - check site parameter after discussion w/Chris 1/6/04
;I '$P($G(^APCDSITE(DUZ(2),0)),U,27) Q ; NO LINKING BY CLINIC PER LINDA FELS
;if both v record clinic and visit record clinic are not null, and they match, re-link v record and quit
;I $P(APCDK12N,U,3)]"",$P(^AUPNVSIT(APCDKXVS,0),U,8)]"",$P(APCDK12N,U,3)=$P(^AUPNVSIT(APCDKXVS,0),U,8) D RELINK Q
ORDERLOC ;check ordering location
I $P(APCDK12N,U,15)]"",$P(^AUPNVSIT(APCDKXVS,0),U,22)]"",$P(APCDK12N,U,15)=$P(^AUPNVSIT(APCDKXVS,0),U,22) D RELINK Q
Q
RELINK ;repoint v file entry
;W !,"Would have re-linked ",APCDKVFL," ",APCDVDFN," to visit ",APCDKXVS Q
K DIE,DR,DA,DIU,DIV S DITC="",DA=APCDVDFN,DIE=APCDKVDG,DR=".03////"_APCDKXVS D ^DIE K DIE,DA,DR,DIU,DIV,DITC
;I APCDKVFL=9000010.09 D LABLRO
I (APCDKVFL=9000010.09)!(APCDKVFL=9000010.25)!(APCDKVFL=9000010.31) D LABLRO ;NEW LINE
NEW AUPNVSIT S AUPNVSIT=APCDKXVS D MOD^AUPNVSIT
;update new log with from visit, to visit, multiple of v file
D UPDLOG(APCDKVFL,APCDVDFN,APCDKXVS,APCDKV,APCDRUND,"N")
Q
;
UPDLOG(VF,VFI,TV,FV,RD,TYPE) ;EP - CALLED FROM APCDKDE
D EN^XBNEW("UPDLOG1^APCDK","VF;VFI;TV;FV;RD;TYPE")
Q
UPDLOG1 ;EP
NEW APCDLOGX
NEW DIC,DIADD,DLAYGO,DIE,DR,DA,X
S APCDLOGX=$O(^APCDKLOG("AA",RD,FV,0))
I APCDLOGX D UPDMULT K APCDLOGX Q
S X=RD,DIADD=1,DLAYGO=9001003.91,DIC(0)="L",DIC="^APCDKLOG(",DIC("DR")=".02////"_$P(^AUPNVSIT(TV,0),U,5)_";.03////"_$P(^AUPNVSIT(TV,0),U,1)_";.04////"_FV_";.05////"_TV_";.06////"_TYPE K DD,D0,DO D FILE^DICN K DIC,DIADD,DLAYGO,X
S APCDLOGX=+Y
;
UPDMULT ;
S X="`"_VF,DIC="^APCDKLOG("_APCDLOGX_",11,",DIC(0)="L",DIC("P")=$P(^DD(9001003.91,1101,0),U,2),DA(1)=APCDLOGX
D ^DIC
;NO ERROR
S DIE=DIC K DIC
S DA=+Y
S DR=".02////"_VFI
D ^DIE
K DIC,X,DA,DIE,DR
Q
LABLRO ;
;if this is a v lab go fix LR(68.999999901 for backwards compatibility with ALR and LAB
;S APCDKORD=$P($G(^AUPNVLAB(APCDVDFN,11)),U,2)
NEW APCDFILE S APCDFILE=APCDKVDG_"APCDVDFN,11)" ;IHS/ITSC/LJF
S APCDKORD=$P($G(@APCDFILE),U,2) ;IHS/ITSC/LJF 4/21/2004
I APCDKORD]"" D
.K APCDKIEN S I=0 F S I=$O(^LRO(68.999999901,"AC",APCDKV,I)) Q:I'=+I I $P($G(^LRO(68.999999901,I,0)),U,3)=APCDKORD S APCDKIEN=I
.I $G(APCDKIEN),$P(^LRO(68.999999901,APCDKIEN,0),U,2)'=APCDKXVS S DA=APCDKIEN,DIE="^LRO(68.999999901,",DR=".02////"_APCDKXVS D ^DIE K DA,DR,DIE
K APCDKIEN,APCDKORD,I
Q
CHECKV ;check visit to see if should be deleted
S X=$$EN1^APCDKFDE(APCDKV)
Q
;
NOVFILES(V) ;check to see if any vfiles, if so return a 1
I $D(^AUPNVMSR("AD",V)) Q 0
I $D(^AUPNVINP("AD",V)) Q 0
I $D(^AUPNVCHS("AD",V)) Q 0
I $D(^AUPNVEYE("AD",V)) Q 0
I $D(^AUPNVDEN("AD",V)) Q 0
I $D(^AUPNVPRV("AD",V)) Q 0
I $D(^AUPNVPOV("AD",V)) Q 0
I $D(^AUPNVPRC("AD",V)) Q 0
I $D(^AUPNVLAB("AD",V)) Q 0
I $D(^AUPNVIMM("AD",V)) Q 0
I $D(^AUPNVSK("AD",V)) Q 0
I $D(^AUPNVXAM("AD",V)) Q 0
I $D(^AUPNVMED("AD",V)) Q 0
I $D(^AUPNVTRT("AD",V)) Q 0
I $D(^AUPNVCPT("AD",V)) Q 0
I $D(^AUPNVTM("AD",V)) Q 0
I $D(^AUPNVDXP("AD",V)) Q 0
I $D(^AUPNVRAD("AD",V)) Q 0
I $D(^AUPNVHF("AD",V)) Q 0
I $D(^AUPNVPTH("AD",V)) Q 0
I $D(^AUPNVMIC("AD",V)) Q 0
I $D(^AUPNVNOT("AD",V)) Q 0
I $D(^AUPNVER("AD",V)) Q 0
I $D(^AUPNVBB("AD",V)) Q 0
I $D(^AUPNVPHN("AD",V)) Q 0
I $D(^AUPNVTC("AD",V)) Q 0
I $D(^AUPNVNT("AD",V)) Q 0
I $D(^AUPNVELD("AD",V)) Q 0
I $D(^AUPNVTRC("AD",V)) Q 0
I $D(^AUPNVUNH("AD",V)) Q 0
I $D(^AUPNVTXC("AD",V)) Q 0
I $D(^AUPNVAST("AD",V)) Q 0
I $D(^AUPNVPOD("AD",V)) Q 0
Q 1
APCDK ; IHS/CMI/LAB - NIGHTLY AMBULATORY VISIT V FILE RELINKER ; 15 Nov 2010 12:10 PM
+1 ;;2.0;IHS PCC SUITE;**1,5,10**;MAY 14, 2009;Build 88
+2 ;
+3 ;
EN ;
+1 ;run in hospital re-linker to link I's to H's
DO ^APCDCHKJ
+2 ;dtc re-linker
DO ^APCDKDTC
+3 SET X1=DT
SET X2=-91
DO C^%DTC
SET APCDK("DATE")=X_.999999
+4 SET U="^"
SET (APCDK("VISITS"),APCDK("RELINK"))=0
SET APCDRUND=DT
+5 ;go through B index and get all visits since 61 days ago
+6 SET APCDKVD=APCDK("DATE")
FOR
SET APCDKVD=$ORDER(^AUPNVSIT("B",APCDKVD))
IF APCDKVD'=+APCDKVD
QUIT
Begin DoDot:1
+7 SET APCDKV=0
FOR
SET APCDKV=$ORDER(^AUPNVSIT("B",APCDKVD,APCDKV))
IF APCDKV'=+APCDKV
QUIT
DO PROCESS
End DoDot:1
+8 KILL APCDKVD
+9 DO EOJ
+10 QUIT
EOJ ;
+1 SET DA=1
SET DIE="^AUTTSITE("
SET DR=".24////^S X=DT"
DO ^DIE
KILL DA,DIE,DR
+2 ;update rpms site file, no error checking
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 KILL APCDKV,APCDKNV,APCDKMM,APCDKVFL,APCDKVDG,APCDKIGR,APCDVDFN,APCDK12N,APCDK,APCDKX,APCDKDSP,APCDKHI,APCDKPAT,APCDKAVD,APCDKAVC,APCDKVCT,APCDKDVR,APCDRUND
+5 KILL DIE,DA,DR,DIU,DIV,DIC
+6 QUIT
+7 ;
PROCESS ;Get vars and process visit
+1 IF '$DATA(^AUPNVSIT(APCDKV))
QUIT
+2 IF $PIECE(^AUPNVSIT(APCDKV,0),U,11)
QUIT
+3 ;delete visits with no patient
SET DFN=$PIECE(^AUPNVSIT(APCDKV,0),U,5)
IF DFN=""
IF $PIECE(^AUPNVSIT(APCDKV,0),U,2)]""
IF $PIECE(^AUPNVSIT(APCDKV,0),U,2)'=DT
IF $$NOVFILES(APCDKV)
SET DA=APCDKV
SET DIK="^AUPNVSIT("
DO ^DIK
QUIT
+4 IF '$PIECE(^AUPNVSIT(APCDKV,0),U,9)
QUIT
+5 ;Quit if current ER patient
IF $$GET1^DIQ(9009080,DFN,"1.1","I")=APCDKV
QUIT
+6 ;only review ambulatory visits
IF "AORSX"'[$PIECE(^AUPNVSIT(APCDKV,0),U,7)
QUIT
+7 ;leave complete visit alone
IF $DATA(^AUPNVPOV("AD",APCDKV))
QUIT
+8 ;leave complete visit alone
IF $DATA(^AUPNVPRV("AD",APCDKV))
QUIT
+9 SET DFN=$PIECE(^AUPNVSIT(APCDKV,0),U,5)
GVISITS ;go through all A and X visits on this date for this patient
+1 SET APCDKXVS=0
SET (APCDKAVD,APCDKAVC)=9999999-$PIECE($PIECE(^AUPNVSIT(APCDKV,0),U),".")
SET APCDKAVD=(APCDKAVD-1)_".9999999"
+2 FOR
SET APCDKAVD=$ORDER(^AUPNVSIT("AA",DFN,APCDKAVD))
IF APCDKAVD=""
QUIT
IF $PIECE(APCDKAVD,".")'=APCDKAVC
QUIT
Begin DoDot:1
+3 FOR APCDKXVS=0:0
SET APCDKXVS=$ORDER(^AUPNVSIT("AA",DFN,APCDKAVD,APCDKXVS))
IF APCDKXVS=""
QUIT
Begin DoDot:2
+4 ;don't compare to self
IF APCDKV=APCDKXVS
QUIT
+5 IF $PIECE(^AUPNVSIT(APCDKXVS,0),U,11)
QUIT
+6 ;do not use incomplete visits to link to
IF '$DATA(^AUPNVPOV("AD",APCDKXVS))
QUIT
+7 ;quit if not a complete visit
IF '$DATA(^AUPNVPRV("AD",APCDKXVS))
QUIT
+8 ;don't use visits with differing facilities
IF $PIECE(^AUPNVSIT(APCDKXVS,0),U,6)'=$PIECE(^AUPNVSIT(APCDKV,0),U,6)
QUIT
+9 ;link to ambulatory only
IF "AORSX"'[$PIECE(^AUPNVSIT(APCDKXVS,0),U,7)
QUIT
+10 NEW X,P,S
SET (S,X)=0
SET APCDKDSP=""
FOR
SET X=$ORDER(^AUPNVPRV("AD",APCDKXVS,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVPRV(X,0),U,4)="P"
SET APCDKDPP=+^(0)
IF $PIECE(^(0),U,4)="S"!($PIECE(^(0),U,4)="")
SET S=S+1
SET $PIECE(APCDKDSP,U,S)=+^(0)
+11 SET APCDKVFL=9000010
FOR
SET APCDKVFL=$ORDER(^DIC(APCDKVFL))
IF APCDKVFL>9000010.99!(APCDKVFL'=+APCDKVFL)
QUIT
DO VENTRIES
+12 ;go through all V file entries
End DoDot:2
DO CHECKV
+13 QUIT
End DoDot:1
+14 QUIT
VENTRIES ;
+1 SET APCDKVDG=^DIC(APCDKVFL,0,"GL")
SET APCDKIGR=APCDKVDG_"""AD"",APCDKV,APCDVDFN)"
+2 SET APCDVDFN=""
FOR APCDVI=1:1
SET APCDVDFN=$ORDER(@APCDKIGR)
IF APCDVDFN=""
QUIT
DO CHECK
+3 QUIT
+4 ;
CHECK ;
+1 SET APCDK12N=APCDKVDG_APCDVDFN_",12)"
+2 IF '$DATA(@(APCDK12N))
QUIT
+3 SET APCDK12N=@(APCDK12N)
+4 IF APCDK12N=""
QUIT
ENCPROV ;
+1 ;if both v record encounter provider and any provider in V Provider for this visit match, re-link and quit (both must have a value)
+2 ;G ORDPROV ;IHS/ANMC/LAB - 9/23/98 per Chris Saddler ;IHS/CMI/LAB
+3 ;IHS/CMI/LAB for V NOTE
IF APCDKVFL'=9000010.28
IF APCDKVFL'=9000010.11
GOTO ORDPROV
+4 SET APCDKVFP=""
+5 IF $PIECE(APCDK12N,U,4)=""
GOTO ORDPROV
+6 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
IF $PIECE(^DD(APCDKVFL,1204,0),U,2)[200
SET APCDKVFP=$PIECE(^VA(200,$PIECE(APCDK12N,U,4),0),U,16)
+7 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
IF $PIECE(^DD(APCDKVFL,1204,0),U,2)[200
SET APCDKVFP=$PIECE(APCDK12N,U,4)
+8 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
IF $PIECE(^DD(APCDKVFL,1204,0),U,2)[6
SET APCDKVFP=$PIECE(APCDK12N,U,4)
+9 IF APCDKVFP=""
GOTO ORDPROV
+10 IF $GET(APCDKDPP)=APCDKVFP
DO RELINK
QUIT
+11 SET X=0
FOR I=1:1
SET X=$PIECE(APCDKDSP,U,I)
IF X=""
QUIT
IF APCDKVFP=X
DO RELINK
QUIT
+12 ;I $G(APCDKDPP)=$P(APCDK12N,U,4) D RELINK Q
+13 ;S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I $P(APCDK12N,U,4)=X D RELINK Q
ORDPROV ;
+1 SET APCDKVFP=""
+2 IF $PIECE(APCDK12N,U,2)=""
GOTO CLIN
+3 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
IF $PIECE(^DD(APCDKVFL,1202,0),U,2)[200
SET APCDKVFP=$PIECE(^VA(200,$PIECE(APCDK12N,U,2),0),U,16)
+4 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
IF $PIECE(^DD(APCDKVFL,1202,0),U,2)[200
SET APCDKVFP=$PIECE(APCDK12N,U,2)
+5 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
IF $PIECE(^DD(APCDKVFL,1202,0),U,2)[6
SET APCDKVFP=$PIECE(APCDK12N,U,2)
+6 IF APCDKVFP=""
GOTO CLIN
+7 IF $GET(APCDKDPP)=APCDKVFP
DO RELINK
QUIT
+8 SET X=0
FOR I=1:1
SET X=$PIECE(APCDKDSP,U,I)
IF X=""
QUIT
IF APCDKVFP=X
DO RELINK
QUIT
+9 ;G:$P(APCDK12N,U,2)="" CLIN
+10 ;I $G(APCDKDPP)=$P(APCDK12N,U,2) D RELINK Q
+11 ;S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I $P(APCDK12N,U,2)=X D RELINK Q
CLIN ;check clinic
+1 ;Q ;per discussion with Linda ;IHS/CMI/LAB - check site parameter after discussion w/Chris 1/6/04
+2 ;I '$P($G(^APCDSITE(DUZ(2),0)),U,27) Q ; NO LINKING BY CLINIC PER LINDA FELS
+3 ;if both v record clinic and visit record clinic are not null, and they match, re-link v record and quit
+4 ;I $P(APCDK12N,U,3)]"",$P(^AUPNVSIT(APCDKXVS,0),U,8)]"",$P(APCDK12N,U,3)=$P(^AUPNVSIT(APCDKXVS,0),U,8) D RELINK Q
ORDERLOC ;check ordering location
+1 IF $PIECE(APCDK12N,U,15)]""
IF $PIECE(^AUPNVSIT(APCDKXVS,0),U,22)]""
IF $PIECE(APCDK12N,U,15)=$PIECE(^AUPNVSIT(APCDKXVS,0),U,22)
DO RELINK
QUIT
+2 QUIT
RELINK ;repoint v file entry
+1 ;W !,"Would have re-linked ",APCDKVFL," ",APCDVDFN," to visit ",APCDKXVS Q
+2 KILL DIE,DR,DA,DIU,DIV
SET DITC=""
SET DA=APCDVDFN
SET DIE=APCDKVDG
SET DR=".03////"_APCDKXVS
DO ^DIE
KILL DIE,DA,DR,DIU,DIV,DITC
+3 ;I APCDKVFL=9000010.09 D LABLRO
+4 ;NEW LINE
IF (APCDKVFL=9000010.09)!(APCDKVFL=9000010.25)!(APCDKVFL=9000010.31)
DO LABLRO
+5 NEW AUPNVSIT
SET AUPNVSIT=APCDKXVS
DO MOD^AUPNVSIT
+6 ;update new log with from visit, to visit, multiple of v file
+7 DO UPDLOG(APCDKVFL,APCDVDFN,APCDKXVS,APCDKV,APCDRUND,"N")
+8 QUIT
+9 ;
UPDLOG(VF,VFI,TV,FV,RD,TYPE) ;EP - CALLED FROM APCDKDE
+1 DO EN^XBNEW("UPDLOG1^APCDK","VF;VFI;TV;FV;RD;TYPE")
+2 QUIT
UPDLOG1 ;EP
+1 NEW APCDLOGX
+2 NEW DIC,DIADD,DLAYGO,DIE,DR,DA,X
+3 SET APCDLOGX=$ORDER(^APCDKLOG("AA",RD,FV,0))
+4 IF APCDLOGX
DO UPDMULT
KILL APCDLOGX
QUIT
+5 SET X=RD
SET DIADD=1
SET DLAYGO=9001003.91
SET DIC(0)="L"
SET DIC="^APCDKLOG("
SET DIC("DR")=".02////"_$PIECE(^AUPNVSIT(TV,0),U,5)_";.03////"_$PIECE(^AUPNVSIT(TV,0),U,1)_";.04////"_FV_";.05////"_TV_";.06////"_TYPE
KILL DD,D0,DO
DO FILE^DICN
KILL DIC,DIADD,DLAYGO,X
+6 SET APCDLOGX=+Y
+7 ;
UPDMULT ;
+1 SET X="`"_VF
SET DIC="^APCDKLOG("_APCDLOGX_",11,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9001003.91,1101,0),U,2)
SET DA(1)=APCDLOGX
+2 DO ^DIC
+3 ;NO ERROR
+4 SET DIE=DIC
KILL DIC
+5 SET DA=+Y
+6 SET DR=".02////"_VFI
+7 DO ^DIE
+8 KILL DIC,X,DA,DIE,DR
+9 QUIT
LABLRO ;
+1 ;if this is a v lab go fix LR(68.999999901 for backwards compatibility with ALR and LAB
+2 ;S APCDKORD=$P($G(^AUPNVLAB(APCDVDFN,11)),U,2)
+3 ;IHS/ITSC/LJF
NEW APCDFILE
SET APCDFILE=APCDKVDG_"APCDVDFN,11)"
+4 ;IHS/ITSC/LJF 4/21/2004
SET APCDKORD=$PIECE($GET(@APCDFILE),U,2)
+5 IF APCDKORD]""
Begin DoDot:1
+6 KILL APCDKIEN
SET I=0
FOR
SET I=$ORDER(^LRO(68.999999901,"AC",APCDKV,I))
IF I'=+I
QUIT
IF $PIECE($GET(^LRO(68.999999901,I,0)),U,3)=APCDKORD
SET APCDKIEN=I
+7 IF $GET(APCDKIEN)
IF $PIECE(^LRO(68.999999901,APCDKIEN,0),U,2)'=APCDKXVS
SET DA=APCDKIEN
SET DIE="^LRO(68.999999901,"
SET DR=".02////"_APCDKXVS
DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+8 KILL APCDKIEN,APCDKORD,I
+9 QUIT
CHECKV ;check visit to see if should be deleted
+1 SET X=$$EN1^APCDKFDE(APCDKV)
+2 QUIT
+3 ;
NOVFILES(V) ;check to see if any vfiles, if so return a 1
+1 IF $DATA(^AUPNVMSR("AD",V))
QUIT 0
+2 IF $DATA(^AUPNVINP("AD",V))
QUIT 0
+3 IF $DATA(^AUPNVCHS("AD",V))
QUIT 0
+4 IF $DATA(^AUPNVEYE("AD",V))
QUIT 0
+5 IF $DATA(^AUPNVDEN("AD",V))
QUIT 0
+6 IF $DATA(^AUPNVPRV("AD",V))
QUIT 0
+7 IF $DATA(^AUPNVPOV("AD",V))
QUIT 0
+8 IF $DATA(^AUPNVPRC("AD",V))
QUIT 0
+9 IF $DATA(^AUPNVLAB("AD",V))
QUIT 0
+10 IF $DATA(^AUPNVIMM("AD",V))
QUIT 0
+11 IF $DATA(^AUPNVSK("AD",V))
QUIT 0
+12 IF $DATA(^AUPNVXAM("AD",V))
QUIT 0
+13 IF $DATA(^AUPNVMED("AD",V))
QUIT 0
+14 IF $DATA(^AUPNVTRT("AD",V))
QUIT 0
+15 IF $DATA(^AUPNVCPT("AD",V))
QUIT 0
+16 IF $DATA(^AUPNVTM("AD",V))
QUIT 0
+17 IF $DATA(^AUPNVDXP("AD",V))
QUIT 0
+18 IF $DATA(^AUPNVRAD("AD",V))
QUIT 0
+19 IF $DATA(^AUPNVHF("AD",V))
QUIT 0
+20 IF $DATA(^AUPNVPTH("AD",V))
QUIT 0
+21 IF $DATA(^AUPNVMIC("AD",V))
QUIT 0
+22 IF $DATA(^AUPNVNOT("AD",V))
QUIT 0
+23 IF $DATA(^AUPNVER("AD",V))
QUIT 0
+24 IF $DATA(^AUPNVBB("AD",V))
QUIT 0
+25 IF $DATA(^AUPNVPHN("AD",V))
QUIT 0
+26 IF $DATA(^AUPNVTC("AD",V))
QUIT 0
+27 IF $DATA(^AUPNVNT("AD",V))
QUIT 0
+28 IF $DATA(^AUPNVELD("AD",V))
QUIT 0
+29 IF $DATA(^AUPNVTRC("AD",V))
QUIT 0
+30 IF $DATA(^AUPNVUNH("AD",V))
QUIT 0
+31 IF $DATA(^AUPNVTXC("AD",V))
QUIT 0
+32 IF $DATA(^AUPNVAST("AD",V))
QUIT 0
+33 IF $DATA(^AUPNVPOD("AD",V))
QUIT 0
+34 QUIT 1
