Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDKDE

APCDKDE.m

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