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