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

AGCVT3.m

Go to the documentation of this file.
  1. AGCVT3 ; IHS/ASDS/EFG - COMPUTE BIC ELIGIBILITY, OR SET TO "C"-NOT REVIEWED ;
  1. ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
  1. ;
  1. ; A rough calculation indicates that it would take approximately
  1. ; a week of continual execution for this routine to work its way
  1. ; thru a database of 50,000 patients.
  1. Q
  1. START ;
  1. I '$D(DTIME) S DTIME=300
  1. I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
  1. W $$S^AGVDF("IOF"),!!
  1. W ?31,"*** AGCVT3 ***",!!
  1. W "This routine reads thru the PATIENT file, and,",!
  1. W "if the BIC ELIGIBILITY STATUS does not exist, computes it."
  1. W !!,"It will take about ",$J(+$P(^AUPNPAT(0),U,4)*(285/1077)/60,5,1)," minutes",!
  1. W "to run this utility thru your ",$P(^AUPNPAT(0),U,4)," entries.",!!
  1. K DIR,DTOUT,DUOUT,DFOUT,DQOUT,DIRUT,DIROUT,DLOUT
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you want to continue? (Y/N) "
  1. S DIR("B")="NO"
  1. D ^DIR
  1. Q:Y=0
  1. USER I '($D(DUZ)#2) W !! S DIC="^VA(200,",DIC("A")="Who are you?",DIC(0)="AEFMNQ" D ^DIC G:+Y<0 END S DUZ=+Y
  1. FACILITY I '$D(DUZ(2)) S DUZ(2)=0 D SET^XBSITE K DIC I '$D(DUZ(2)) G END
  1. I '$D(DUZ(0)) S DUZ(0)="@"
  1. QUE ;
  1. K DIR,DTOUT,DUOUT,DFOUT,DQOUT,DIRUT,DIROUT,DLOUT
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you want to q this process? (Y/N) "
  1. S DIR("B")="YES"
  1. D ^DIR
  1. G END:$D(DTOUT)!(Y["^")
  1. G ENTRY:Y=0
  1. DEV X ^%ZOSF("UCI") S ZTRTN="ENTRY^AGCVT3",ZTUCI=Y,ZTIO="",ZTDESC="Calc BIC Eligibility, for "_$P(^AUTTLOC(DUZ(2),0),U,2)_"." S ZTSAVE=""
  1. D ^%ZTLOAD G:'$D(ZTSK) QUE W !!,"Task Number = ",ZTSK,!!,"Press RETURN..." R Y:DTIME K AG,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZTUCI D ^%ZISC Q
  1. ENTRY ;EP - TaskMan.
  1. S AGHIDA=+$P(^AUPNPAT(0),U,3)
  1. I '$D(ZTQUEUED) S IOP=ION D ^%ZIS,WAIT^DICD S DX=$X,DY=$Y+1
  1. F DA=1:1:AGHIDA I $D(^AUPNPAT(DA)),$D(^(DA,11)),$P(^(11),U,24)="" S DFN=DA D ^AGBIC2C I $P(^AUPNPAT(DA,11),U,24)="" S DIE="^AUPNPAT(",DR="1124///C" D ^DIE
  1. I '$D(ZTQUEUED) W !!?25,"AGCVT3 SUCCCESSFULLY COMPLETED",!!
  1. END K DA,DIC,DR,DX,DY,AGHIDA
  1. Q
  1. READ K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT
  1. S DIR(0)="Y"
  1. D ^DIR
  1. S:Y="/.," (DFOUT,Y)=""
  1. S:Y="" DLOUT=""
  1. S:Y="^" (DUOUT,Y)=""
  1. S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
  1. Q
  1. TEST ;For testing, enter here to set all BIC ELIGIBILITY STATUS and
  1. ;DATE ELIGIBILITY DETERMINED fields to blank.
  1. ;
  1. S IOP=ION D ^%ZIS,WAIT^DICD S DX=$X,DY=$Y+1
  1. S AGHIDA=+$P(^AUPNPAT(0),U,3) F DA=1:1:AGHIDA X XY W DA I $D(^AUPNPAT(DA)),$D(^(DA,11)) I ($P(^(11),U,23)]"")!($P(^(11),U,24)]"") S $P(^(11),U,23,24)=""