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

APCDKBV.m

Go to the documentation of this file. 
  1. APCDKBV ; IHS/CMI/LAB - LINK DIF DAY BLOOD BANK VISITS ;
  1.  ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ; -- ** THANKS TO LINDA FELS
  1.  ;    ** FOR THE ORIGINAL ROUTINE.
  1.  ; -- This routine takes visits with only v blood bank entries and completes
  1.  ;     them with a pov of lab draw and lab tech as the provider.
  1.  ;     Using the order date, the original visit is searched for. 
  1.  ;     If found, the original visit is set in the Billing Link field
  1.  ;     of the Visit file for the lab only visit.
  1.  ;
  1.  Q
  1.  ;
  1. QUEUE ;EP; entry point to run linker in background
  1.  I '$D(ZTQUEUED) W !!,"Orphaned V Blood Bank Linker is being queued to run in the background!",!,"Dates of the run will be automatically calculated based on the PCC delay",!,"value.",!
  1.  NEW DELAY,X1,X2,X
  1.  Q:'$$LABTECH  Q:'$$LABCLN
  1.  S DELAY=$$VALI^XBDIQ1(9001005.1,1,.03),DELAY=DELAY+7
  1.  S X1=DT,X2=-DELAY D C^%DTC S APCDED=X
  1.  S X1=APCDED,X2=-60 D C^%DTC S APCDBD=X
  1.  NEW X
  1.  S X=$P(^AUTTSITE(1,0),U,24)
  1.  Q:X=""  ;visit re-linker has not been run - send mail message?
  1.  I X<APCDED Q  ;visit re-linker not run up to ending date
  1.  D START(1)
  1.  Q
  1.  ;
  1.  ;
  1. MANUAL ;EP; entry to run linker manually
  1.  NEW DIR,X,Y,DELAY,X1,X2
  1.  D ^XBCLS W !!?20,"FIX UNLINKED BLOOD BANK VISITS",!!
  1.  ;
  1.  I '$$LABTECH D  Q
  1.  . W !!,$C(7),"You do not have a generic Lab Technician provider entry"
  1.  . W !,"in your database.  Cannot run fix for unlinked V BLOOD BANK visits."
  1.  . S DIR(0)="E",DIR("A")="Press ENTER" D ^DIR
  1.  ;
  1.  I '$$LABCLN D  Q
  1.  . W !!,$C(7),"You do not have LABORATORY as a clinic stop.  Cannot run"
  1.  . W !,"fix for unlinked labs."
  1.  . S DIR(0)="E",DIR("A")="Press ENTER" D ^DIR
  1.  ;
  1. DATES K APCDED,APCDBD
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date for Search"
  1.  D ^DIR Q:Y<1  S APCDBD=Y
  1.  K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Date for Search"
  1.  D ^DIR Q:Y<1  S APCDED=Y
  1.  ;
  1.  I APCDED<APCDBD D  G DATES
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  ;
  1.  S DELAY=$$VALI^XBDIQ1(9001005.1,1,.03)
  1.  S X1=DT,X2=-DELAY D C^%DTC I APCDED>X D  G DATES
  1.  . W !!,$C(7),"Sorry, Cannot pick date within PCC Delay.  Select a date"
  1.  . W !,"earlier than ",$$FMTE^XLFDT(X,5),"."
  1.  ;
  1.  S DELAY=$P(^AUTTSITE(1,0),U,24)
  1.  I DELAY="" D  G DATES
  1.  .W !!,$C(7),"PCC Visit Relinker has not been run.   You cannot complete blood bank visits"
  1.  .W !,"until the re-linker is run.  See your site manager for assistance."
  1.  I DELAY<APCDED D  G DATES
  1.  .W !!,$C(7),"You have picked a date that is later than the date the visit re-linker",!,"was last run.  You must run the visit re-linker first.  See your site manager",!,"for assistance."
  1.  .W "  You must pick an ending date which is earlier than ",$$FMTE^XLFDT(DELAY,5),".",!
  1.  K DIR S DIR(0)="Y"
  1.  S DIR("A")="Do you want these visits transmitted to the Data Center"
  1.  S DIR("?",1)="Answer YES if the data range you have selected is for"
  1.  S DIR("?",2)="the current fiscal year.  You WILL want those visits"
  1.  S DIR("?",3)="transmitted to DDPS.",DIR("?",4)=" "
  1.  S DIR("?",5)="Answer NO if you are running this for past fiscal years."
  1.  S DIR("?")=" " D ^DIR Q:Y=U
  1.  ;
  1.  W !!,"Search begun"
  1.  D START(Y)
  1.  W !!,"Search COMPLETED.  ",+$G(APCDCNT)," Visits fixed."
  1.  Q
  1.  ;
  1.  ;
  1. START(APCDZMOD) ; begin of linker logic
  1.  ; APCDZMOD=1 if MOD^AUPNVSIT is to be called
  1.  NEW APCDT,APCDEND,APCDV,X,Y
  1.  Q:'$G(APCDBD)  Q:'$G(APCDED)
  1.  ;
  1.  ; -- loop visit dates to find unlinked labs
  1.  S APCDCNT=0,APCDT=APCDBD-.0001,APCDEND=APCDED+.2400
  1.  F  S APCDT=$O(^AUPNVSIT("B",APCDT)) Q:'APCDT!(APCDT>APCDEND)  D
  1.  . S APCDV=0
  1.  . F  S APCDV=$O(^AUPNVSIT("B",APCDT,APCDV)) Q:'APCDV  D
  1.  .. I $D(^AUPNVPOV("AD",APCDV))!$D(^AUPNVPRV("AD",APCDV)) Q  ;good vst
  1.  .. Q:'$D(^AUPNVBB("AD",APCDV))  ;not a lab visit
  1.  .. S X=$$VALI^XBDIQ1(9000010,APCDV,.07) I (X'="A"),(X'="S") Q
  1.  .. ;S X=$O(^AUPNVBB("AD",APCDV,0)) I X,$$GET1^DIQ(9000010.31,X,1202)\1=APCDT\1 Q  ;if ordered on same date, quit
  1.  .. S X=$O(^AUPNVBB("AD",APCDV,0)) I X,($P($P($G(^AUPNVBB(X,12)),U,11),".")=$P(APCDT,".")) Q
  1.  .. ;
  1.  .. D LINK(APCDV) ;link to original visit
  1.  .. D STUFF(APCDV,APCDZMOD) ;stuff pov and provider
  1.  .. I '$D(ZTQUEUED) S APCDCNT=$G(APCDCNT)+1 W "."
  1.  .. I $P($G(^APCDSITE(DUZ(2),0)),U,24)="Y" D
  1.  ... K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^APCDLLOG(",DLAYGO=9001001.7,DIADD=1,X=APCDV,DIC("DR")=".02////"_DT_";.03///B" D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
  1.  .. ;W !,APCDT,?20,APCDV Q  ;used to watch progress of rtn
  1.  K APCDED,APCDBD,APCDCNT
  1.  Q
  1.  ;
  1.  ;
  1.  NEW APCDX,APCDLAB,ORDT,ORDPRV,DFN,DATE,PRV,ORDV,LINK
  1.  ;
  1.  ; -- get first lab entry for visit
  1.  S APCDLAB=$O(^AUPNVBB("AD",APCDVST,0)) Q:'APCDLAB
  1.  K APCDX D ENP^XBDIQ1(9000010.31,APCDLAB,".02;1202;1211","APCDX(","I")
  1.  S ORDT=APCDX(1211,"I") Q:ORDT=""        ;order date
  1.  S ORDPRV=APCDX(1202,"I") Q:ORDPRV=""    ;ordering provider
  1.  S DFN=APCDX(.02,"I") Q:DFN=""           ;patient
  1.  ;
  1.  ; -- look for orig visit based on order date for patient and provider
  1.  K LINK S DATE=$$RVDT(ORDT)-.0001,END=$$RVDT(ORDT)+.9999999
  1.  F  S DATE=$O(^AUPNVSIT("AA",DFN,DATE)) Q:'DATE!(DATE>END)!($D(LINK))  D
  1.  . ; -- find all visits for patient on order date
  1.  . S ORDV=0 F  S ORDV=$O(^AUPNVSIT("AA",DFN,DATE,ORDV)) Q:'ORDV  D
  1.  .. ; -- find if ordering provider linked to this visit
  1.  .. S PRV=0 F  S PRV=$O(^AUPNVPRV("AD",ORDV,PRV)) Q:'PRV!($D(LINK))  D
  1.  ... I +^AUPNVPRV(PRV,0)=ORDPRV S LINK=ORDV ;orig visit found
  1.  ;
  1.  ; -- if orig visit found, set link
  1.  I $G(LINK) S DIE=9000010,DA=APCDVST,DR=".28////"_LINK D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. STUFF(AUPNVSIT,APCDZMOD) ; -- stuff pov and provider
  1.  NEW APCDT,APCDV ;protect variables from loop
  1.  NEW APCDALVR,DFN
  1.  S DFN=$$VALI^XBDIQ1(9000010,AUPNVSIT,.05) Q:DFN=""
  1.  ;
  1.  ; -- if okay to transmit, set date modified
  1.  I APCDZMOD D MOD^AUPNVSIT
  1.  ;
  1.  ; -- stuff lab as clinic if clinic is blank
  1.  I $$VALI^XBDIQ1(9000010,AUPNVSIT,.08)="" D
  1.  . S DIE="^AUPNVSIT(",DA=AUPNVSIT,DR=".08////"_$$LABCLN D ^DIE K DIE,DA,DR
  1.  ;
  1.  ; -- create purpose of visit entry
  1.  ; -- uses lab draw (ICD code V72.69)
  1.  K APCDALVR
  1.  S APCDALVR("APCDPAT")=DFN,APCDALVR("APCDVSIT")=AUPNVSIT
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
  1.  S APCDALVR("APCDTPOV")=$$CODE^APCDKLV($$VD^APCLV(AUPNVSIT)) ;"V72.69"
  1.  S APCDALVR("APCDTNQ")="LABORATORY EXAMINATION"
  1.  D ^APCDALVR
  1.  I $D(APCDALVR("APCDAFLG")) Q
  1.  ;
  1.  ; -- create v provider entry
  1.  ; -- uses lab tech (23) plus affiliation based on PCC site type
  1.  K APCDALVR
  1.  S APCDALVR("APCDPAT")=DFN,APCDALVR("APCDVSIT")=AUPNVSIT
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
  1.  I $$PROVP=6 S X=$O(^DIC(6,"GIHS",$$LABTECH,0)) Q:'X
  1.  I $$PROVP=200 S X=$O(^VA(200,"GIHS",$$LABTECH,0)) Q:'X
  1.  S APCDALVR("APCDTPRO")="`"_X
  1.  S APCDALVR("APCDTPS")="P"
  1.  D ^APCDALVR
  1.  ;stuff 1111 field of visit with reviewed status
  1.  S DA=AUPNVSIT,DIE="^AUPNVSIT(",DR="1111///R" D ^DIE K DIE,DA,DR
  1.  Q
  1.  ;
  1. RVDT(X) ; -- returns reverse date 
  1.  Q 9999999-X
  1.  ;
  1. LABTECH() ; -- returns code if lab tech entry exists in file 200
  1.  NEW SITE,CODE
  1.  S SITE=$$VALI^XBDIQ1(9001000,DUZ(2),.04) I SITE="" Q 0
  1.  S CODE=$P($T(@SITE),";;",2)_"23999"
  1.  I $$PROVP=200,'$D(^VA(200,"GIHS",CODE)) Q 0
  1.  I $$PROVP=6,'$D(^DIC(6,"GIHS",CODE)) Q 0
  1.  Q CODE
  1.  ;
  1. PROVP() ; -- returns pointer file # for providers
  1.  NEW X S X=$P(^DD(9000010.06,.01,0),U,2)
  1.  Q $S(X["200":200,1:6)
  1.  ;
  1. LABCLN() ; -- returns ien for lab clinic code
  1.  Q +$O(^DIC(40.7,"C","76",0))
  1.  ;
  1. AFFIL ;; affiliation recode
  1. I ;;1;;IHS
  1. C ;;2;;CONTRACT       
  1. T ;;3;;TRIBAL
  1. O ;;9;;OTHER
  1. 6 ;;8;;638
  1. V ;;9;;VA (OTHER)
  1. P ;;3;;TRIBAL
  1. U ;;9;;OTHER