DVBCAMRO ;ALB ISC/THM-REGIONAL OFFICE 2507 AMIS REPORT ; 9/28/91 6:39 AM
;;2.7;AMIE;**17,149,184,192**;Apr 10, 1995;Build 15
;Per VHA Directive 2004-038, this routine should not be modified.
;
SETUP ;
;
; Check for AMIS 290 replacement URL
;
; Input:
; RTN - Return value, current URL
; WHICH - index of URL to retrieve
;
; Output:
; RTN - URL of location to replace this report
;
N RTN,WHICH
S RTN="",WHICH=7
D URL^DVBABURL(.RTN,WHICH)
I Y'="" W !,"The AMIS 290 Regional Office Report is no longer available here.",!,"Please go to: ",RTN Q
N DVBAPRTY,DVBAEXMP,DVBAP,DTOUT,DUOUT
S UPDATE="N",PREVMO=$P(^DVB(396.1,1,0),U,11),HD="REGIONAL OFFICE 2507 AMIS REPORT" I '$D(DT) S X="T" D ^%DT S DT=Y
S DVBCDT(0)=$$FMTE^XLFDT(DT,"5DZ")
D HOME^%ZIS S FF=IOF
;prompt for priority of exam
S DVBAPRTY=$$EXMPRTY^DVBCIUTL("Select the Priority of Exam for the 2507 AMIS Report")
G:('(DVBAPRTY?.A)!(DVBAPRTY']"")) EXIT ;quit if no priority of exam selected
;
INIT ;initialize counter arrays
S DVBAEXMP=$S($G(DVBAPRTY)["BDD":"BDD,QS",($G(DVBAPRTY)["IDES"):"IDES",($G(DVBAPRTY)["AO"):"AO",1:"ALL")
F JI="3DAYSCH","30DAYEX","PENDADJ" D
.F DVBAP=1:1:$L(DVBAEXMP,",") S TOT($P(DVBAEXMP,",",DVBAP),JI)=0
F JI="INSUFF","SENT","INCOMPLETE","DAYS","COMPLETED" D
.F DVBAP=1:1:$L(DVBAEXMP,",") S TOT($P(DVBAEXMP,",",DVBAP),JI)=0
F JI="P90","P121","P151","P181","P365","P366" D
.F DVBAP=1:1:$L(DVBAEXMP,",") S TOT($P(DVBAEXMP,",",DVBAP),JI)=0
;
EN W @IOF,!?(IOM-$L(HD)\2),HD,!!!
S %DT(0)=-DT,%DT="AE",%DT("A")="Enter STARTING DATE: " D ^%DT G:Y<0 EXIT S BDATE1=Y,BDATE=Y-.1
S %DT="AE",%DT("A")=" and ENDING DATE: " D ^%DT G:Y<0 EN S EDATE1=Y,EDATE=Y+.5
I EDATE1<BDATE1 W *7,!!,"Invalid date sequence - ending date is before starting date.",!! H 3 G EN
W !!,"When selecting regional offices you may enter an individual station name,",!,"station number or nothing if all regional offices should be searched.",!!
S DIC("A")="Select REGIONAL OFFICE NUMBER: ",DIC(0)="AEQM",DIC="^DIC(4," D ^DIC G:($D(DTOUT)!($D(DUOUT))) EXIT
I +Y>0 S DA=+Y,RONUM=$S($D(^DIC(4,DA,99)):$P(^(99),U,1),1:"000"),RONAME=$P(Y,U,2)
I +Y<0 S (RONUM,RONAME)="ALL"
;
ASK K %DT S SBULL="Y" W !!!,"Want to send a bulletin when processing is done" S %=1 D YN^DICN G:$D(DTOUT)!(%<0) EXIT
I $D(%Y) I %Y["?" W !!,"Enter Y to send the bulletin to selected recipients or N not to send it at all.",!! G ASK
I %'=1 S SBULL="N"
I SBULL="Y" D BULL^DVBCAMR2
W ! S %ZIS="AEQ",%ZIS("B")="0;P-OTHER",%ZIS("A")="Output device: " D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="GO^DVBCAMR2",ZTDESC="2507 Amis Report",ZTIO=ION F I="UPDATE","RO*","PREVMO","BDATE*","TOT*","EDATE*","SBULL","DUZ","DVBCDT(0)","XM*","DVBAPRTY" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 1 K ZTSK G EXIT
G GO^DVBCAMR2
;
EXIT K PREVMO,UPDATE G KILL^DVBCUTIL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCAMRO 2899 printed Dec 13, 2024@01:43:31 Page 2
DVBCAMRO ;ALB ISC/THM-REGIONAL OFFICE 2507 AMIS REPORT ; 9/28/91 6:39 AM
+1 ;;2.7;AMIE;**17,149,184,192**;Apr 10, 1995;Build 15
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
SETUP ;
+1 ;
+2 ; Check for AMIS 290 replacement URL
+3 ;
+4 ; Input:
+5 ; RTN - Return value, current URL
+6 ; WHICH - index of URL to retrieve
+7 ;
+8 ; Output:
+9 ; RTN - URL of location to replace this report
+10 ;
+11 NEW RTN,WHICH
+12 SET RTN=""
SET WHICH=7
+13 DO URL^DVBABURL(.RTN,WHICH)
+14 IF Y'=""
WRITE !,"The AMIS 290 Regional Office Report is no longer available here.",!,"Please go to: ",RTN
QUIT
+15 NEW DVBAPRTY,DVBAEXMP,DVBAP,DTOUT,DUOUT
+16 SET UPDATE="N"
SET PREVMO=$PIECE(^DVB(396.1,1,0),U,11)
SET HD="REGIONAL OFFICE 2507 AMIS REPORT"
IF '$DATA(DT)
SET X="T"
DO ^%DT
SET DT=Y
+17 SET DVBCDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+18 DO HOME^%ZIS
SET FF=IOF
+19 ;prompt for priority of exam
+20 SET DVBAPRTY=$$EXMPRTY^DVBCIUTL("Select the Priority of Exam for the 2507 AMIS Report")
+21 ;quit if no priority of exam selected
if ('(DVBAPRTY?.A)!(DVBAPRTY']""))
GOTO EXIT
+22 ;
INIT ;initialize counter arrays
+1 SET DVBAEXMP=$SELECT($GET(DVBAPRTY)["BDD":"BDD,QS",($GET(DVBAPRTY)["IDES"):"IDES",($GET(DVBAPRTY)["AO"):"AO",1:"ALL")
+2 FOR JI="3DAYSCH","30DAYEX","PENDADJ"
Begin DoDot:1
+3 FOR DVBAP=1:1:$LENGTH(DVBAEXMP,",")
SET TOT($PIECE(DVBAEXMP,",",DVBAP),JI)=0
End DoDot:1
+4 FOR JI="INSUFF","SENT","INCOMPLETE","DAYS","COMPLETED"
Begin DoDot:1
+5 FOR DVBAP=1:1:$LENGTH(DVBAEXMP,",")
SET TOT($PIECE(DVBAEXMP,",",DVBAP),JI)=0
End DoDot:1
+6 FOR JI="P90","P121","P151","P181","P365","P366"
Begin DoDot:1
+7 FOR DVBAP=1:1:$LENGTH(DVBAEXMP,",")
SET TOT($PIECE(DVBAEXMP,",",DVBAP),JI)=0
End DoDot:1
+8 ;
EN WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!
+1 SET %DT(0)=-DT
SET %DT="AE"
SET %DT("A")="Enter STARTING DATE: "
DO ^%DT
if Y<0
GOTO EXIT
SET BDATE1=Y
SET BDATE=Y-.1
+2 SET %DT="AE"
SET %DT("A")=" and ENDING DATE: "
DO ^%DT
if Y<0
GOTO EN
SET EDATE1=Y
SET EDATE=Y+.5
+3 IF EDATE1<BDATE1
WRITE *7,!!,"Invalid date sequence - ending date is before starting date.",!!
HANG 3
GOTO EN
+4 WRITE !!,"When selecting regional offices you may enter an individual station name,",!,"station number or nothing if all regional offices should be searched.",!!
+5 SET DIC("A")="Select REGIONAL OFFICE NUMBER: "
SET DIC(0)="AEQM"
SET DIC="^DIC(4,"
DO ^DIC
if ($DATA(DTOUT)!($DATA(DUOUT)))
GOTO EXIT
+6 IF +Y>0
SET DA=+Y
SET RONUM=$SELECT($DATA(^DIC(4,DA,99)):$PIECE(^(99),U,1),1:"000")
SET RONAME=$PIECE(Y,U,2)
+7 IF +Y<0
SET (RONUM,RONAME)="ALL"
+8 ;
ASK KILL %DT
SET SBULL="Y"
WRITE !!!,"Want to send a bulletin when processing is done"
SET %=1
DO YN^DICN
if $DATA(DTOUT)!(%<0)
GOTO EXIT
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to send the bulletin to selected recipients or N not to send it at all.",!!
GOTO ASK
+2 IF %'=1
SET SBULL="N"
+3 IF SBULL="Y"
DO BULL^DVBCAMR2
+4 WRITE !
SET %ZIS="AEQ"
SET %ZIS("B")="0;P-OTHER"
SET %ZIS("A")="Output device: "
DO ^%ZIS
if POP
GOTO EXIT
+5 IF $DATA(IO("Q"))
SET ZTRTN="GO^DVBCAMR2"
SET ZTDESC="2507 Amis Report"
SET ZTIO=ION
FOR I="UPDATE","RO*","PREVMO","BDATE*","TOT*","EDATE*","SBULL","DUZ","DVBCDT(0)","XM*","DVBAPRTY"
SET ZTSAVE(I)=""
+6 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
HANG 1
KILL ZTSK
GOTO EXIT
+7 GOTO GO^DVBCAMR2
+8 ;
EXIT KILL PREVMO,UPDATE
GOTO KILL^DVBCUTIL
