APCDKDE ; IHS/CMI/LAB - POST DATA ENTRY RELINKER ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
EP ;EP find v file entries to re-link to this visit
I '$D(APCDVSIT) Q ;quit if visit not passed
I '$D(^AUPNVSIT(APCDVSIT)) Q ;quit if not valid visit
I "AORSX"'[$P(^AUPNVSIT(APCDVSIT,0),U,7) Q
;
NEW APCDKDEY
D PROCESS
D EOJ
Q
EOJ ;
L -^AUPNVSIT(APCDVSIT,0)
K APCDK,APCDKXVS,APCDVDFN,APCDVI,APCDFDEC,APCDK12N,APCDKAVC,APCDKAVD,APCDKDPP,APCDKDSP,V,APCDKDVS,APCDKFDE,APCDKIGR,APCDKOPP,APCDKOSP,APCDKOVS,DFN,APCDKV,APCDKVDG,APCDKVFL,APCDKVFP
K I,P,X,S,ZTSK
Q
PROCESS ;
W:'$D(ZTQUEUED) !,"Looking for ancillary data to merge into this visit..."
NEW V
L +^AUPNVSIT(APCDVSIT,0):60
S V=^AUPNVSIT(APCDVSIT,0)
Q:$P(V,U,11) ;quit if visit has been deleted
Q:'$P(V,U,9) ;quit if no dependent entries
Q:'$D(^AUPNVPRV("AD",APCDVSIT)) ;quit if not a provider yet
S DFN=$P(V,U,5)
;store v providers in an array
NEW X,P,S S (S,X)=0,APCDKDSP="" F S X=$O(^AUPNVPRV("AD",APCDVSIT,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)
GVISITS ;go through all A and X visits on this date for this patient
S APCDKXVS=0,(APCDKAVD,APCDKAVC)=9999999-$P($P(V,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
..Q:APCDVSIT=APCDKXVS ;don't compare to self
..Q:$P(^AUPNVSIT(APCDKXVS,0),U,11)
..Q:'$P(^AUPNVSIT(APCDKXVS,0),U,9)
..Q:$D(^AUPNVPOV("AD",APCDKXVS)) ;quit if visit already has pov
..Q:$D(^AUPNVPRV("AD",APCDKXVS)) ;quit if this is a complete visit already
..Q:$P(^AUPNVSIT(APCDKXVS,0),U,6)'=$P(^AUPNVSIT(APCDVSIT,0),U,6) ;don't use visits with differing facilities
..Q:"AORSX"'[$P(^AUPNVSIT(APCDKXVS,0),U,7) ;don't link to non Ambulatory
..S APCDKVFL=9000010 F S APCDKVFL=$O(^DIC(APCDKVFL)) Q:APCDKVFL>9000010.99!(APCDKVFL'=+APCDKVFL) D VENTRIES
..D CHECKV
.Q
Q
;
VENTRIES ;
S APCDKVDG=^DIC(APCDKVFL,0,"GL"),APCDKIGR=APCDKVDG_"""AD"",APCDKXVS,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 ;
S APCDKVFP=""
;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:$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)[6,$P(^DD(APCDKVFL,1204,0),U,2)[6 S APCDKVFP=$P(APCDK12N,U,4)
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 APCDKVFP="" G ORDPROV
;I $G(APCDKDPP)=$P(APCDK12N,U,4) D RELINK Q
I $G(APCDKDPP)=APCDKVFP 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
S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I APCDKVFP=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)[6,$P(^DD(APCDKVFL,1202,0),U,2)[6 S APCDKVFP=$P(APCDK12N,U,2)
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 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
;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
;if both v record clinic and visit record clinic are not null, and they match, re-link v record and quit
;Q ;quit per Linda - 1/6/04 - don't quit per Linda's document of 9/28/03 Check site parameter per Chris
;I '$P($G(^APCDSITE(DUZ(2),0)),U,27) Q
;I $P(APCDK12N,U,3)]"",$P(V,U,8)]"",$P(APCDK12N,U,3)=$P(V,U,8) D RELINK Q
ORDERLOC ;check ordering location
I $P(APCDK12N,U,15)]"",$P(V,U,22)]"",$P(APCDK12N,U,15)=$P(V,U,22) D RELINK Q
CHECKXIT ;
Q
RELINK ;repoint v file entry
W:'$D(ZTQUEUED) " ",$P(^DIC(APCDKVFL,0),U)
K DIE,DR,DA,DIU,DIV S DITC="",DA=APCDVDFN,DIE=APCDKVDG,DR=".03////"_APCDVSIT D ^DIE K DIE,DA,DR,DIU,DIV,DITC
I (APCDKVFL=9000010.09)!(APCDKVFL=9000010.25)!(APCDKVFL=9000010.31) D LABLRO
D UPDLOG^APCDK(APCDKVFL,APCDVDFN,APCDVSIT,APCDKXVS,DT,"D")
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",APCDKXVS,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)'=APCDVSIT S DA=APCDKIEN,DIE="^LRO(68.999999901,",DR=".02////"_APCDVSIT D ^DIE K DA,DR,DIE
K APCDKIEN,APCDKORD,I
Q
CHECKV ;check visit to see if should be deleted
S X=$$EN1^APCDKFDE(APCDKXVS)
Q
APCDKDE ; IHS/CMI/LAB - POST DATA ENTRY RELINKER ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
EP ;EP find v file entries to re-link to this visit
+1 ;quit if visit not passed
IF '$DATA(APCDVSIT)
QUIT
+2 ;quit if not valid visit
IF '$DATA(^AUPNVSIT(APCDVSIT))
QUIT
+3 IF "AORSX"'[$PIECE(^AUPNVSIT(APCDVSIT,0),U,7)
QUIT
+4 ;
+5 NEW APCDKDEY
+6 DO PROCESS
+7 DO EOJ
+8 QUIT
EOJ ;
+1 LOCK -^AUPNVSIT(APCDVSIT,0)
+2 KILL APCDK,APCDKXVS,APCDVDFN,APCDVI,APCDFDEC,APCDK12N,APCDKAVC,APCDKAVD,APCDKDPP,APCDKDSP,V,APCDKDVS,APCDKFDE,APCDKIGR,APCDKOPP,APCDKOSP,APCDKOVS,DFN,APCDKV,APCDKVDG,APCDKVFL,APCDKVFP
+3 KILL I,P,X,S,ZTSK
+4 QUIT
PROCESS ;
+1 IF '$DATA(ZTQUEUED)
WRITE !,"Looking for ancillary data to merge into this visit..."
+2 NEW V
+3 LOCK +^AUPNVSIT(APCDVSIT,0):60
+4 SET V=^AUPNVSIT(APCDVSIT,0)
+5 ;quit if visit has been deleted
IF $PIECE(V,U,11)
QUIT
+6 ;quit if no dependent entries
IF '$PIECE(V,U,9)
QUIT
+7 ;quit if not a provider yet
IF '$DATA(^AUPNVPRV("AD",APCDVSIT))
QUIT
+8 SET DFN=$PIECE(V,U,5)
+9 ;store v providers in an array
+10 NEW X,P,S
SET (S,X)=0
SET APCDKDSP=""
FOR
SET X=$ORDER(^AUPNVPRV("AD",APCDVSIT,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)
GVISITS ;go through all A and X visits on this date for this patient
+1 SET APCDKXVS=0
SET (APCDKAVD,APCDKAVC)=9999999-$PIECE($PIECE(V,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 APCDVSIT=APCDKXVS
QUIT
+5 IF $PIECE(^AUPNVSIT(APCDKXVS,0),U,11)
QUIT
+6 IF '$PIECE(^AUPNVSIT(APCDKXVS,0),U,9)
QUIT
+7 ;quit if visit already has pov
IF $DATA(^AUPNVPOV("AD",APCDKXVS))
QUIT
+8 ;quit if this is a complete visit already
IF $DATA(^AUPNVPRV("AD",APCDKXVS))
QUIT
+9 ;don't use visits with differing facilities
IF $PIECE(^AUPNVSIT(APCDKXVS,0),U,6)'=$PIECE(^AUPNVSIT(APCDVSIT,0),U,6)
QUIT
+10 ;don't link to non Ambulatory
IF "AORSX"'[$PIECE(^AUPNVSIT(APCDKXVS,0),U,7)
QUIT
+11 SET APCDKVFL=9000010
FOR
SET APCDKVFL=$ORDER(^DIC(APCDKVFL))
IF APCDKVFL>9000010.99!(APCDKVFL'=+APCDKVFL)
QUIT
DO VENTRIES
+12 DO CHECKV
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
VENTRIES ;
+1 SET APCDKVDG=^DIC(APCDKVFL,0,"GL")
SET APCDKIGR=APCDKVDG_"""AD"",APCDKXVS,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 SET APCDKVFP=""
+2 ;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)
+3 IF $PIECE(APCDK12N,U,4)=""
GOTO ORDPROV
+4 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)
+5 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)
+6 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)
+7 IF APCDKVFP=""
GOTO ORDPROV
+8 ;I $G(APCDKDPP)=$P(APCDK12N,U,4) D RELINK Q
+9 IF $GET(APCDKDPP)=APCDKVFP
DO RELINK
QUIT
+10 ;S X=0 F I=1:1 S X=$P(APCDKDSP,U,I) Q:X="" I $P(APCDK12N,U,4)=X D RELINK Q
+11 SET X=0
FOR I=1:1
SET X=$PIECE(APCDKDSP,U,I)
IF X=""
QUIT
IF APCDKVFP=X
DO RELINK
QUIT
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)[6
IF $PIECE(^DD(APCDKVFL,1202,0),U,2)[6
SET APCDKVFP=$PIECE(APCDK12N,U,2)
+5 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)
+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 ;I $G(APCDKDPP)=$P(APCDK12N,U,2) D RELINK Q
+10 ;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 ;if both v record clinic and visit record clinic are not null, and they match, re-link v record and quit
+2 ;Q ;quit per Linda - 1/6/04 - don't quit per Linda's document of 9/28/03 Check site parameter per Chris
+3 ;I '$P($G(^APCDSITE(DUZ(2),0)),U,27) Q
+4 ;I $P(APCDK12N,U,3)]"",$P(V,U,8)]"",$P(APCDK12N,U,3)=$P(V,U,8) D RELINK Q
ORDERLOC ;check ordering location
+1 IF $PIECE(APCDK12N,U,15)]""
IF $PIECE(V,U,22)]""
IF $PIECE(APCDK12N,U,15)=$PIECE(V,U,22)
DO RELINK
QUIT
CHECKXIT ;
+1 QUIT
RELINK ;repoint v file entry
+1 IF '$DATA(ZTQUEUED)
WRITE " ",$PIECE(^DIC(APCDKVFL,0),U)
+2 KILL DIE,DR,DA,DIU,DIV
SET DITC=""
SET DA=APCDVDFN
SET DIE=APCDKVDG
SET DR=".03////"_APCDVSIT
DO ^DIE
KILL DIE,DA,DR,DIU,DIV,DITC
+3 IF (APCDKVFL=9000010.09)!(APCDKVFL=9000010.25)!(APCDKVFL=9000010.31)
DO LABLRO
+4 DO UPDLOG^APCDK(APCDKVFL,APCDVDFN,APCDVSIT,APCDKXVS,DT,"D")
+5 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",APCDKXVS,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)'=APCDVSIT
SET DA=APCDKIEN
SET DIE="^LRO(68.999999901,"
SET DR=".02////"_APCDVSIT
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(APCDKXVS)
+2 QUIT
