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

APCDKIV.m

Go to the documentation of this file. 
  1. APCDKIV ; IHS/CMI/LAB - LINK DIF DAY IMMUNIZATION VISITS ;
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ; -- ** THANKS TO LINDA FELS, ANMC COMPUTER DEPARTMENT
  1.  ;    ** FOR THIS ROUTINE.
  1.  ; -- This routine takes visits with only v imm entries and completes
  1.  ;     them with a pov of rx refill and pharmacist 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 rad only visit.
  1.  ;
  1.  Q
  1.  ;
  1. QUEUE ;EP; entry point to run linker in background
  1.  I '$D(ZTQUEUED) W !!,"Orphaned Immunization 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:'$$IMMCLN
  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 IMMUNIZATION VISITS",!!
  1.  ;
  1.  I '$$IMMCLN D  Q
  1.  . W !!,$C(7),"You do not have IMMUNIZATION as a clinic stop.  Cannot run"
  1.  . W !,"fix for unlinked immunization visits."
  1.  . S DIR(0)="E",DIR("A")="Press ENTER" D ^DIR
  1.  ;
  1. DATES K APCDED,APCDBD
  1.  W !,"When choosing a date rante for visits keep in mind that you should run this",!,"utility for visit dates that have not been completed by data entry.",!!
  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 rad 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 imms
  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(^AUPNVIMM("AD",APCDV))  ;not a imm visit
  1.  .. S X=$$VALI^XBDIQ1(9000010,APCDV,.07) I (X'="A"),(X'="S") Q  ;only ambulatory
  1.  .. ;S X=$O(^AUPNVIMM("AD",APCDV,0)) I X,$$GET1^DIQ(9000010.09,X,1204)\1=APCDT\1 Q  ;if ordered on same date, quit
  1.  .. ;S X=$O(^AUPNVIMM("AD",APCDV,0)) I X,($P($P($G(^AUPNVIMM(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///I" 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,APCDIMM,ORDT,ORDPRV,DFN,DATE,PRV,ORDV,LINK
  1.  ;
  1.  ; -- get first rx entry for visit
  1.  S APCDIMM=$O(^AUPNVIMM("AD",APCDVST,0)) Q:'APCDIMM
  1.  K APCDX D ENP^XBDIQ1(9000010.11,APCDIMM,".02;1204;1211","APCDX(","I")
  1.  S ORDT=APCDX(1211,"I") Q:ORDT=""        ;order date
  1.  S ORDPRV=APCDX(1204,"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 imm as clinic if clinic is blank
  1.  I $$VALI^XBDIQ1(9000010,AUPNVSIT,.08)="" D
  1.  . S DIE="^AUPNVSIT(",DA=AUPNVSIT,DR=".08////"_$$IMMCLN D ^DIE
  1.  ;
  1.  ; -- create purpose of visit entry
  1.  ; -- uses imm code from V immumization entries
  1.  S APCDIMM=0 F  S APCDIMM=$O(^AUPNVIMM("AD",AUPNVSIT,APCDIMM)) Q:APCDIMM'=+APCDIMM  D
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDPAT")=DFN,APCDALVR("APCDVSIT")=AUPNVSIT
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
  1.  .S APCDI=$P(^AUPNVIMM(APCDIMM,0),U),I=$P(^AUTTIMM(APCDI,0),U,14)
  1.  .S APCDALVR("APCDTPOV")=$$CODE($$VD^APCLV(AUPNVSIT))
  1.  .S APCDALVR("APCDTNQ")=$P(^AUTTIMM(APCDI,0),U)_" ***IMMUNIZATION***"
  1.  .D ^APCDALVR
  1.  ;
  1.  ; -- create v provider entry
  1.  ; -- uses immprov (1204 field value)
  1.  K APCDIMPR
  1.  S APCDIMM=0 F  S APCDIMM=$O(^AUPNVIMM("AD",AUPNVSIT,APCDIMM)) Q:APCDIMM'=+APCDIMM  D
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDPAT")=DFN,APCDALVR("APCDVSIT")=AUPNVSIT
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
  1.  .S APCDX=$P($G(^AUPNVIMM(APCDIMM,12)),U,4)
  1.  .Q:'APCDX
  1.  .I $$PROVP=6 S APCDX=$P(^VA(200,APCDX,0),U,16)
  1.  .Q:$D(APCDIMPR(APCDX))  ;already have this provider
  1.  .S APCDALVR("APCDTPRO")="`"_APCDX
  1.  .S APCDALVR("APCDTPS")=$S($D(APCDIMPR):"S",1:"P")
  1.  .D ^APCDALVR
  1.  .I '$D(APCDALVR("APCDAFLG")) S APCDIMPR(APCDX)=""
  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. CODE(D) ;
  1.  NEW C
  1.  S C=$$IMP^AUPNSICD(D)
  1.  I C=30 Q "Z41.8"
  1.  Q "V07.9"
  1.  ;
  1. RVDT(X) ; -- returns reverse date 
  1.  Q 9999999-X
  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. IMMCLN() ; -- returns ien for imm clinic code
  1.  Q +$O(^DIC(40.7,"C","12",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