- 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)=""