QANRPT1 ;HISC/GJC-SUMMARY OF INCIDENTS/WARD ;5/6/91
;;2.0;Incident Reporting;**26,29**;08/07/1992
;
N QANINFLG,QANLCFLG
F W !,"Do you wish to produce a report by Incident Location" S %=1 D YN^DICN Q:"-112"[% W !,$C(7),"Enter ""Y""es to issue a report by Incident Location,",!,"""N""o to issue a report by Patient's Ward."
I %=-1 K % Q
S:%=2 QANCHOS="W" S:%=1 QANCHOS="I"
D DIV
DATE ;
D ^QAQDATE I QAQQUIT W !!,$C(7),"Invalid date range, no report will be produced." D KILL Q
S (PAGE,QANTYPE)=0
I $D(QAQNBEG) S Y=QAQNBEG D DD^%DT S QANDATE(0)=Y
S:$D(QAQNBEG) QAQNBEG=QAQNBEG-.00000001
S:$D(QAQNEND) QAQNEND=QAQNEND_".99999999"
S QANHEAD(0)="QUALITY MANAGEMENT INCIDENT REPORT",QANHEAD(1)="SUMMARY OF INCIDENTS BY INCIDENT LOCATION",QANHEAD(2)="SUMMARY OF INCIDENTS BY PATIENT WARD"
S Y=$P(QAQNEND,".") D DD^%DT S QANDATE(1)=Y
S QANHEAD(3)="FOR THE PERIOD "_QANDATE(0)_" TO "_QANDATE(1)
D INCD^QANUTL4 I QANY D KILL Q
D:QANCHOS="I" QANLOC^QANUTL4 D:QANCHOS="W" WARD^QANUTL4 I QANY D KILL Q
LOOP ;
N QANCC,QANEE
S QANEE=QAQNBEG
F S QANEE=$O(^QA(742.4,"BDT",QANEE)) Q:QANEE'>0!(QANEE>QAQNEND) D
. S QANCC=0
. F S QANCC=$O(^QA(742.4,"BDT",QANEE,QANCC)) Q:QANCC'>0 D
. . S QANDD=0
. . F S QANDD=$O(^QA(742,"BCS",QANCC,QANDD)) Q:QANDD'>0 D
. . . S QAN7424=^QA(742.4,QANCC,0) Q:$G(QAN7424)']""
. . . S QAN742=^QA(742,QANDD,0) Q:$G(QAN742)']""
. . . I $P(QAN7424,U,8)=2 Q
. . . S QANINC=$P(QAN7424,U,2) I $G(QANINC)']"" Q
. . . I $G(QANINFLG)'=1 I $G(^TMP("QANRPT1",$J,"INC",QANINC))']"" Q
. . . I $P(QAN742,U,5)'=1 Q
. . . S QANLCN=$S($G(QANCHOS)="I":$P(QAN7424,U,4),1:$P(QAN742,U,6)) Q:'$G(QANLCN)
. . . I $G(QANCHOS)="I" S QANLOC=$P(^QA(742.5,QANLCN,0),U)
. . . I $G(QANCHOS)="W" S QANLOC=$P(^SC($P(QAN742,U,6),0),U)
. . . I $G(QANLOC)']"" Q
. . . I $G(QANLCFLG)'=1 I $G(^TMP("QANRPT1",$J,"LOC",QANLCN))']"" Q
. . . S QANDIV=$P(QAN7424,U,22) I $G(QANDIV)']"" S QANDIV=0
. . . I $G(QAN1DIV)]"" Q:QAN1DIV'=QANDIV
. . . I '$D(^QA(740,1,"QAN2","B",QANDIV)) S QANDIV=0
. . . I $P($G(^QA(740,1,"QAN")),U,5)'=1 S QANDIV=0
. . . S QANINC=$P(^QA(742.1,QANINC,0),U)
. . . S QANINC=$TR(QANINC,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
. . . S ^TMP("QANRPT1",$J,"QAN",QANDIV,QANLOC,QANINC,QANCC,QANDD)=""
I '$D(^TMP("QANRPT1",$J)) W !!,$C(7),"No records found for the selected date range." D KILL Q
S QANWORD=$S($G(QANCHOS)="I":"Incident",1:"Ward")
I '$G(QANLCFLG),('$D(^TMP("QANRPT1",$J,"LOC"))) W !!,$C(7),QANWORD," location(s) not found, exiting the report." D KILL Q
I '$G(QANINFLG),('$D(^TMP("QANRPT1",$J,"INC"))) W !!,$C(7),"Incident(s) not found, exiting the report." D KILL Q
D TOTAL
TASK S Y=DT X ^DD("DD") S TODAY=Y,$P(BNDRY,"-",$S(IOM=132:133,1:81))="",QANFIN=""
;*** Choose device ***
K IOP,%ZIS S %ZIS("A")="Print on device: ",%ZIS="MQ" W ! D ^%ZIS W !!
G:POP KILL
I $D(IO("Q")) S ZTRTN="STRT^QANRPT1",ZTDESC="Generate Incident reports for incidents by type." D QLOOP^QANRPT2,^%ZTLOAD W !,$S($D(ZTSK):"Request queued!",1:"Request cancelled!"),! G EXIT
STRT U IO
D:QANFIN'["^" PRINT
EXIT W ! D ^%ZISC,HOME^%ZIS
KILL ;Kill and quit.
D K^QAQDATE
K QAQNBEG,QAQNEND
K QAN742,QAN7424,QANAA,QANBB,QANCC,QANDD,QANEE,QANFF,QANXX,QANYY,QANZZ
K BNDRY,COUNT,LOOP,PAGE,TODAY,X,Y,%
K QANCDNT,QANCHOS,QANCNT,QANDAT1,QANDAT2,QANDATA1,QANDATA2,QANDATE
K QANDIV,QANDV,QANDVFLG,QANDVN,QANDVSN,QANFLG,QANFIN,QANINC,QANINFLG
K QANHEAD,QANINC,QANINCID,QAN,QANLCFLG,QANLOC,QANLOCA
K QANNODE,QANNUM,QANTYPE,QANY
K ^TMP("QANRPT1"),LP,LP0,LP1,LP2,QA,C
K DIROUT,DIRUT,DTOUT,DUOUT,D
Q
FINAL ;Final data summation.
D:$Y>(IOSL-4) HDH,HDR^QANAUX1 Q:QANFIN["^"
I $G(COUNT("TOT"))'>0 W !!,"No incidents found, exiting the report." Q
S QANFF=""
F S QANFF=$O(COUNT("LOC",QANAA,QANFF)) Q:QANFF']"" D
. S QANLOCA=QANFF
. W !,"Total number of incidents for "_$S(QANCHOS="W":"ward ",1:"incident location ")_QANLOCA_": "_COUNT("LOC",QANAA,QANFF)
I $G(QANDVFLG)=1 W !!,"Total number of Incidents for division "_QANDV_": "_COUNT("DIV",QANAA)
W !!,"Total number of incidents this reporting period: "_COUNT("TOT")
D HDH
Q
TOTAL ;
N QANAA,QANBB,QANCC,QANDD
S QANAA=""
F S QANAA=$O(^TMP("QANRPT1",$J,"QAN",QANAA)) Q:QANAA']"" D
. S QANBB=""
. F S QANBB=$O(^TMP("QANRPT1",$J,"QAN",QANAA,QANBB)) Q:QANBB']"" D
. . S QANCC=""
. . F S QANCC=$O(^TMP("QANRPT1",$J,"QAN",QANAA,QANBB,QANCC)) Q:QANCC']"" D
. . . S QANDD=0
. . . F S QANDD=$O(^TMP("QANRPT1",$J,"QAN",QANAA,QANBB,QANCC,QANDD)) Q:QANDD'>0 D
. . . . S COUNT("INC",QANAA,QANBB,QANCC)=$G(COUNT("INC",QANAA,QANBB,QANCC))+1
. . . . S COUNT("TOT")=$G(COUNT("TOT"))+1
. . . . S COUNT("DIV",QANAA)=$G(COUNT("DIV",QANAA))+1
. . . . S COUNT("LOC",QANAA,QANBB)=$G(COUNT("LOC",QANAA,QANBB))+1
Q
HDH ;
I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 QANFIN="^"
Q
WARD ;
N QANCNT,QANDD
S QANDD=0
S QANCNT=1
F S QANDD=$O(^QA(742,"BCS",QANIEN,QANDD)) Q:QANDD'>0 D
. Q:'$P($G(^QA(742,QANDD,0)),U,6)
. S QANLOC(QANCNT)=$P(^QA(742,QANDD,0),U,6)
. S QANCNT=QANCNT+1
Q
INST(QANIEN,QANDV) ;api for getting division name
N DIC
K QANDV
S DIC="^DIC(4,"
S DIC(0)="NZX"
S DIC("S")="I $D(^QA(740,1,""QAN2"",""B"",X))"
S X=QANIEN
D ^DIC K DIC
I Y<0 S QANDV="Unknown" Q
S QANDV=Y(0,0)
Q
PRINT ;print or display data
I '$D(COUNT) G FINAL
S QANAA=""
F S QANAA=$O(COUNT("INC",QANAA)) Q:QANAA']"" D
. D INST(QANAA,.QANDV)
. I $G(QANDVFLG)=1 S QANHEAD(4)="REPORT FOR DIVISION: "_QANDV
. D HDR^QANAUX1
. S QANBB=""
. F S QANBB=$O(COUNT("INC",QANAA,QANBB)) Q:QANBB']"" D
. . D:$Y>(IOSL-6) HDH,HDR^QANAUX1 Q:QANFIN["^" W !!,$E(QANBB,1,32)
. . S QANCC=""
. . F S QANCC=$O(COUNT("INC",QANAA,QANBB,QANCC)) Q:QANCC']"" D
. . . S QANDD=$O(^TMP("QANRPT1",$J,"QAN",QANAA,QANBB,QANCC,0)) Q:QANDD'>0
. . . S QANINCID=$P(^QA(742.1,$P(^QA(742.4,QANDD,0),U,2),0),U)
. . . S QANNUM=COUNT("INC",QANAA,QANBB,QANCC)
. . . D:$Y>(IOSL-4) HDH,HDR^QANAUX1 W ?35,$E(QANINCID,1,35),?72,QANNUM,!
. D FINAL
Q
DIV ;
K QANDVFLG,QAN1DIV
S QANDVFLG=$P($G(^QA(740,1,"QAN")),U,5)
Q:$G(QANDVFLG)'=1
N DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="YA"
S DIR("A")="Select ALL Divisions? "
S DIR("B")="YES"
D ^DIR K DIR I $D(DIRUT) S QANPOP=1 Q
I Y S QAN1DIV="" Q
N DIC
S DIC="^QA(740,1,""QAN2"","
S DIC(0)="AEMZQ"
S DIC("A")="Enter Division: "
S QANDVSN=$O(^QA(740,1,"QAN2",0)) Q:$G(QANDVSN)'>0
D INST($G(^QA(740,1,"QAN2",QANDVSN,0)),.QANDVN)
S DIC("B")=$G(QANDVN)
D ^DIC K DIC
I +Y>0 S QAN1DIV=Y(0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANRPT1 6571 printed Dec 13, 2024@02:00:06 Page 2
QANRPT1 ;HISC/GJC-SUMMARY OF INCIDENTS/WARD ;5/6/91
+1 ;;2.0;Incident Reporting;**26,29**;08/07/1992
+2 ;
+3 NEW QANINFLG,QANLCFLG
+4 FOR
WRITE !,"Do you wish to produce a report by Incident Location"
SET %=1
DO YN^DICN
if "-112"[%
QUIT
WRITE !,$CHAR(7),"Enter ""Y""es to issue a report by Incident Location,",!,"""N""o to issue a report by Patient's Ward."
+5 IF %=-1
KILL %
QUIT
+6 if %=2
SET QANCHOS="W"
if %=1
SET QANCHOS="I"
+7 DO DIV
DATE ;
+1 DO ^QAQDATE
IF QAQQUIT
WRITE !!,$CHAR(7),"Invalid date range, no report will be produced."
DO KILL
QUIT
+2 SET (PAGE,QANTYPE)=0
+3 IF $DATA(QAQNBEG)
SET Y=QAQNBEG
DO DD^%DT
SET QANDATE(0)=Y
+4 if $DATA(QAQNBEG)
SET QAQNBEG=QAQNBEG-.00000001
+5 if $DATA(QAQNEND)
SET QAQNEND=QAQNEND_".99999999"
+6 SET QANHEAD(0)="QUALITY MANAGEMENT INCIDENT REPORT"
SET QANHEAD(1)="SUMMARY OF INCIDENTS BY INCIDENT LOCATION"
SET QANHEAD(2)="SUMMARY OF INCIDENTS BY PATIENT WARD"
+7 SET Y=$PIECE(QAQNEND,".")
DO DD^%DT
SET QANDATE(1)=Y
+8 SET QANHEAD(3)="FOR THE PERIOD "_QANDATE(0)_" TO "_QANDATE(1)
+9 DO INCD^QANUTL4
IF QANY
DO KILL
QUIT
+10 if QANCHOS="I"
DO QANLOC^QANUTL4
if QANCHOS="W"
DO WARD^QANUTL4
IF QANY
DO KILL
QUIT
LOOP ;
+1 NEW QANCC,QANEE
+2 SET QANEE=QAQNBEG
+3 FOR
SET QANEE=$ORDER(^QA(742.4,"BDT",QANEE))
if QANEE'>0!(QANEE>QAQNEND)
QUIT
Begin DoDot:1
+4 SET QANCC=0
+5 FOR
SET QANCC=$ORDER(^QA(742.4,"BDT",QANEE,QANCC))
if QANCC'>0
QUIT
Begin DoDot:2
+6 SET QANDD=0
+7 FOR
SET QANDD=$ORDER(^QA(742,"BCS",QANCC,QANDD))
if QANDD'>0
QUIT
Begin DoDot:3
+8 SET QAN7424=^QA(742.4,QANCC,0)
if $GET(QAN7424)']""
QUIT
+9 SET QAN742=^QA(742,QANDD,0)
if $GET(QAN742)']""
QUIT
+10 IF $PIECE(QAN7424,U,8)=2
QUIT
+11 SET QANINC=$PIECE(QAN7424,U,2)
IF $GET(QANINC)']""
QUIT
+12 IF $GET(QANINFLG)'=1
IF $GET(^TMP("QANRPT1",$JOB,"INC",QANINC))']""
QUIT
+13 IF $PIECE(QAN742,U,5)'=1
QUIT
+14 SET QANLCN=$SELECT($GET(QANCHOS)="I":$PIECE(QAN7424,U,4),1:$PIECE(QAN742,U,6))
if '$GET(QANLCN)
QUIT
+15 IF $GET(QANCHOS)="I"
SET QANLOC=$PIECE(^QA(742.5,QANLCN,0),U)
+16 IF $GET(QANCHOS)="W"
SET QANLOC=$PIECE(^SC($PIECE(QAN742,U,6),0),U)
+17 IF $GET(QANLOC)']""
QUIT
+18 IF $GET(QANLCFLG)'=1
IF $GET(^TMP("QANRPT1",$JOB,"LOC",QANLCN))']""
QUIT
+19 SET QANDIV=$PIECE(QAN7424,U,22)
IF $GET(QANDIV)']""
SET QANDIV=0
+20 IF $GET(QAN1DIV)]""
if QAN1DIV'=QANDIV
QUIT
+21 IF '$DATA(^QA(740,1,"QAN2","B",QANDIV))
SET QANDIV=0
+22 IF $PIECE($GET(^QA(740,1,"QAN")),U,5)'=1
SET QANDIV=0
+23 SET QANINC=$PIECE(^QA(742.1,QANINC,0),U)
+24 SET QANINC=$TRANSLATE(QANINC,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+25 SET ^TMP("QANRPT1",$JOB,"QAN",QANDIV,QANLOC,QANINC,QANCC,QANDD)=""
End DoDot:3
End DoDot:2
End DoDot:1
+26 IF '$DATA(^TMP("QANRPT1",$JOB))
WRITE !!,$CHAR(7),"No records found for the selected date range."
DO KILL
QUIT
+27 SET QANWORD=$SELECT($GET(QANCHOS)="I":"Incident",1:"Ward")
+28 IF '$GET(QANLCFLG)
IF ('$DATA(^TMP("QANRPT1",$JOB,"LOC")))
WRITE !!,$CHAR(7),QANWORD," location(s) not found, exiting the report."
DO KILL
QUIT
+29 IF '$GET(QANINFLG)
IF ('$DATA(^TMP("QANRPT1",$JOB,"INC")))
WRITE !!,$CHAR(7),"Incident(s) not found, exiting the report."
DO KILL
QUIT
+30 DO TOTAL
TASK SET Y=DT
XECUTE ^DD("DD")
SET TODAY=Y
SET $PIECE(BNDRY,"-",$SELECT(IOM=132:133,1:81))=""
SET QANFIN=""
+1 ;*** Choose device ***
+2 KILL IOP,%ZIS
SET %ZIS("A")="Print on device: "
SET %ZIS="MQ"
WRITE !
DO ^%ZIS
WRITE !!
+3 if POP
GOTO KILL
+4 IF $DATA(IO("Q"))
SET ZTRTN="STRT^QANRPT1"
SET ZTDESC="Generate Incident reports for incidents by type."
DO QLOOP^QANRPT2
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request queued!",1:"Request cancelled!"),!
GOTO EXIT
STRT USE IO
+1 if QANFIN'["^"
DO PRINT
EXIT WRITE !
DO ^%ZISC
DO HOME^%ZIS
KILL ;Kill and quit.
+1 DO K^QAQDATE
+2 KILL QAQNBEG,QAQNEND
+3 KILL QAN742,QAN7424,QANAA,QANBB,QANCC,QANDD,QANEE,QANFF,QANXX,QANYY,QANZZ
+4 KILL BNDRY,COUNT,LOOP,PAGE,TODAY,X,Y,%
+5 KILL QANCDNT,QANCHOS,QANCNT,QANDAT1,QANDAT2,QANDATA1,QANDATA2,QANDATE
+6 KILL QANDIV,QANDV,QANDVFLG,QANDVN,QANDVSN,QANFLG,QANFIN,QANINC,QANINFLG
+7 KILL QANHEAD,QANINC,QANINCID,QAN,QANLCFLG,QANLOC,QANLOCA
+8 KILL QANNODE,QANNUM,QANTYPE,QANY
+9 KILL ^TMP("QANRPT1"),LP,LP0,LP1,LP2,QA,C
+10 KILL DIROUT,DIRUT,DTOUT,DUOUT,D
+11 QUIT
FINAL ;Final data summation.
+1 if $Y>(IOSL-4)
DO HDH
DO HDR^QANAUX1
if QANFIN["^"
QUIT
+2 IF $GET(COUNT("TOT"))'>0
WRITE !!,"No incidents found, exiting the report."
QUIT
+3 SET QANFF=""
+4 FOR
SET QANFF=$ORDER(COUNT("LOC",QANAA,QANFF))
if QANFF']""
QUIT
Begin DoDot:1
+5 SET QANLOCA=QANFF
+6 WRITE !,"Total number of incidents for "_$SELECT(QANCHOS="W":"ward ",1:"incident location ")_QANLOCA_": "_COUNT("LOC",QANAA,QANFF)
End DoDot:1
+7 IF $GET(QANDVFLG)=1
WRITE !!,"Total number of Incidents for division "_QANDV_": "_COUNT("DIV",QANAA)
+8 WRITE !!,"Total number of incidents this reporting period: "_COUNT("TOT")
+9 DO HDH
+10 QUIT
TOTAL ;
+1 NEW QANAA,QANBB,QANCC,QANDD
+2 SET QANAA=""
+3 FOR
SET QANAA=$ORDER(^TMP("QANRPT1",$JOB,"QAN",QANAA))
if QANAA']""
QUIT
Begin DoDot:1
+4 SET QANBB=""
+5 FOR
SET QANBB=$ORDER(^TMP("QANRPT1",$JOB,"QAN",QANAA,QANBB))
if QANBB']""
QUIT
Begin DoDot:2
+6 SET QANCC=""
+7 FOR
SET QANCC=$ORDER(^TMP("QANRPT1",$JOB,"QAN",QANAA,QANBB,QANCC))
if QANCC']""
QUIT
Begin DoDot:3
+8 SET QANDD=0
+9 FOR
SET QANDD=$ORDER(^TMP("QANRPT1",$JOB,"QAN",QANAA,QANBB,QANCC,QANDD))
if QANDD'>0
QUIT
Begin DoDot:4
+10 SET COUNT("INC",QANAA,QANBB,QANCC)=$GET(COUNT("INC",QANAA,QANBB,QANCC))+1
+11 SET COUNT("TOT")=$GET(COUNT("TOT"))+1
+12 SET COUNT("DIV",QANAA)=$GET(COUNT("DIV",QANAA))+1
+13 SET COUNT("LOC",QANAA,QANBB)=$GET(COUNT("LOC",QANAA,QANBB))+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
HDH ;
+1 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET QANFIN="^"
+2 QUIT
WARD ;
+1 NEW QANCNT,QANDD
+2 SET QANDD=0
+3 SET QANCNT=1
+4 FOR
SET QANDD=$ORDER(^QA(742,"BCS",QANIEN,QANDD))
if QANDD'>0
QUIT
Begin DoDot:1
+5 if '$PIECE($GET(^QA(742,QANDD,0)),U,6)
QUIT
+6 SET QANLOC(QANCNT)=$PIECE(^QA(742,QANDD,0),U,6)
+7 SET QANCNT=QANCNT+1
End DoDot:1
+8 QUIT
INST(QANIEN,QANDV) ;api for getting division name
+1 NEW DIC
+2 KILL QANDV
+3 SET DIC="^DIC(4,"
+4 SET DIC(0)="NZX"
+5 SET DIC("S")="I $D(^QA(740,1,""QAN2"",""B"",X))"
+6 SET X=QANIEN
+7 DO ^DIC
KILL DIC
+8 IF Y<0
SET QANDV="Unknown"
QUIT
+9 SET QANDV=Y(0,0)
+10 QUIT
PRINT ;print or display data
+1 IF '$DATA(COUNT)
GOTO FINAL
+2 SET QANAA=""
+3 FOR
SET QANAA=$ORDER(COUNT("INC",QANAA))
if QANAA']""
QUIT
Begin DoDot:1
+4 DO INST(QANAA,.QANDV)
+5 IF $GET(QANDVFLG)=1
SET QANHEAD(4)="REPORT FOR DIVISION: "_QANDV
+6 DO HDR^QANAUX1
+7 SET QANBB=""
+8 FOR
SET QANBB=$ORDER(COUNT("INC",QANAA,QANBB))
if QANBB']""
QUIT
Begin DoDot:2
+9 if $Y>(IOSL-6)
DO HDH
DO HDR^QANAUX1
if QANFIN["^"
QUIT
WRITE !!,$EXTRACT(QANBB,1,32)
+10 SET QANCC=""
+11 FOR
SET QANCC=$ORDER(COUNT("INC",QANAA,QANBB,QANCC))
if QANCC']""
QUIT
Begin DoDot:3
+12 SET QANDD=$ORDER(^TMP("QANRPT1",$JOB,"QAN",QANAA,QANBB,QANCC,0))
if QANDD'>0
QUIT
+13 SET QANINCID=$PIECE(^QA(742.1,$PIECE(^QA(742.4,QANDD,0),U,2),0),U)
+14 SET QANNUM=COUNT("INC",QANAA,QANBB,QANCC)
+15 if $Y>(IOSL-4)
DO HDH
DO HDR^QANAUX1
WRITE ?35,$EXTRACT(QANINCID,1,35),?72,QANNUM,!
End DoDot:3
End DoDot:2
+16 DO FINAL
End DoDot:1
+17 QUIT
DIV ;
+1 KILL QANDVFLG,QAN1DIV
+2 SET QANDVFLG=$PIECE($GET(^QA(740,1,"QAN")),U,5)
+3 if $GET(QANDVFLG)'=1
QUIT
+4 NEW DIR,DIRUT,DTOUT,DUOUT
+5 SET DIR(0)="YA"
+6 SET DIR("A")="Select ALL Divisions? "
+7 SET DIR("B")="YES"
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET QANPOP=1
QUIT
+9 IF Y
SET QAN1DIV=""
QUIT
+10 NEW DIC
+11 SET DIC="^QA(740,1,""QAN2"","
+12 SET DIC(0)="AEMZQ"
+13 SET DIC("A")="Enter Division: "
+14 SET QANDVSN=$ORDER(^QA(740,1,"QAN2",0))
if $GET(QANDVSN)'>0
QUIT
+15 DO INST($GET(^QA(740,1,"QAN2",QANDVSN,0)),.QANDVN)
+16 SET DIC("B")=$GET(QANDVN)
+17 DO ^DIC
KILL DIC
+18 IF +Y>0
SET QAN1DIV=Y(0)
+19 QUIT
