Routine: APCDK

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

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

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

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

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

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")

UPDLOG(VF,VFI,TV,FV,RD,TYPE) ;EP - CALLED FROM APCDKDE

 D EN^XBNEW("UPDLOG1^APCDK","VF;VFI;TV;FV;RD;TYPE")

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

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

CHECKV ;check visit to see if should be deleted

 S X=$$EN1^APCDKFDE(APCDKV)

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

APCDK.m