- 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 Mar 13, 2025@20:48:13 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
