PSDSUBOX ;BHAM ISC/JAM - DEA DATA - Waived Practitioner Report ;05 July 2011 5:30 pm
;;3.0;CONTROLLED SUBSTANCES;**73,83**;13 Feb 97;Build 10
;External reference to ^PS(59 supported by DBIA #2621
;External reference to ^PSRX( supported by DBIA #1977
;External reference to ^PSDRUG( supported by DBIA #221
;
;ask division/site
N PSDIV,PSPRV,RPTYP,PSDED,PSDBD,PSDSD
D DIVSEL(.PSDIV) I $G(PSDIV)="^" G EXIT
I $G(PSDIV)="^ALL" S PSDIV=0 F S PSDIV=$O(^PS(59,PSDIV)) Q:'PSDIV I $S('$D(^PS(59,+PSDIV,"I")):1,'^("I"):1,DT'>^("I"):1,1:0) S PSDIV(PSDIV)=""
I '$D(PSDIV) G EXIT
;
DATE ;ask date range
W ! K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " D ^%DT
I Y<0!($D(DTOUT)) G EXIT
S (%DT(0),PSDBD)=Y,%DT("A")="End Date: "
W ! D ^%DT I Y<0!($D(DTOUT)) G EXIT
S PSDED=Y,PSDSD=PSDBD-.000001
PRV ;ask provider(s)
W !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
K PRV,DIC S DIC("A")="Select Provider: ",DIC=200,DIC(0)="QEAM"
S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
F D ^DIC Q:+Y<0 S PSPRV(+Y)=""
K DIC I $$UP^XLFSTR(X)="^ALL" K DUOUT G TYP
I ($D(DUOUT))!($D(DTOUT)) G EXIT
I '$D(PSPRV)&(Y<0) G PRV
TYP ;ask report selection - detail or summary
S DIR(0)="SA^D:Detailed;S:Summary",DIR("A")="Detailed/Summary Report: ",DIR("B")="D"
D ^DIR
I $D(DIRUT) G EXIT
S RPTYP=Y
W ! K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !!,"NO DEVICE SELECTED OR REPORT PRINTED!!",! K IOP G EXIT
I $D(IO("Q")) D G EXIT
.S ZTRTN="RPT^PSDSUBOX",ZTDESC="DEA Waived Practitioner Report",ZTSAVE("PSDIV(")="",ZTSAVE("PSPRV(")=""
.F G="PSDSD","PSDED","PSDBD","RPTYP" S:$D(@G) ZTSAVE(G)=""
.D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! D HOME^%ZIS K ZTSK,IO("Q")
U IO
;
RPT ;generate report
N RXN,ND0,ND2,DRGDA,DRGNM,DEA,DIV,PRVDA,PRVNM,PG,DTM,PATIEN
S PG=1,DTM=$$FMTE^XLFDT(DT)
K ^TMP("PSDSUBOX",$J),^TMP("PSDSUBOXC",$J)
F S PSDSD=$O(^PSRX("AFDT",PSDSD)) Q:'PSDSD!(PSDSD>(PSDED+.99)) D
.S RXN=0 F S RXN=$O(^PSRX("AFDT",PSDSD,RXN)) Q:'RXN D
..S ND0=$G(^PSRX(RXN,0)),DRGDA=$P(ND0,"^",6),DRGNM=$$GET1^DIQ(50,DRGDA,.01),DEA=$$GET1^DIQ(50,DRGDA,3),PATIEN=$P(ND0,U,2)
..Q:DEA<1 Q:DEA>5 Q:'$$DETOX^PSSOPKI(DRGDA)
..S ND2=$G(^PSRX(RXN,2)),DIV=$P(ND2,"^",9),PRVDA=$P(ND0,"^",4),PRVNM=$$GET1^DIQ(59,PRVDA,.01)
..I '$D(PSDIV(+DIV)) Q
..I $D(PSPRV) I '$D(PSPRV(+PRVDA)) Q
..D SETMP
D PRT
;
EXIT D ^%ZISC K PG,G,DR,X,Y,DIR,DIRUT,DUOUT,I,Y,DIC,DTOUT,%DT
K ZTDESC,ZTRTN,ZTSAVE S:$D(ZTQUEUED) ZTREQ="@" K ZTQUEUED D KVA^VADPT
Q
;
SETMP ;set ^TMP("PSDSUBOX",$J global
N DRUGINFO,PROVIEN
S DRUGINFO=$E(DRGNM,1,50)_"^"_DRGDA
S PROVIEN=$E(PRVNM,1,50)_"^"_PRVDA
;S ^TMP("PSDSUBOX",$J,DIV,DRUGINFO,PROVIEN)=$G(^TMP("PSDSUBOX",$J,DIV,DRUGINFO,PROVIEN))+1
S ^TMP("PSDSUBOX",$J,DIV,PROVIEN,DRUGINFO,RXN)=""
I '$D(^TMP("PSDSUBOXC",$J,DIV,PROVIEN,PATIEN)) D
.S ^TMP("PSDSUBOXC",$J,DIV,PROVIEN,PATIEN)=""
.S ^TMP("PSDSUBOXC",$J,DIV,PROVIEN)=$G(^TMP("PSDSUBOXC",$J,DIV,PROVIEN))+1
Q
;
PRT ;prints report
N DIV,DRG,PRV,PSDATE,PEDATE,PSDOUT
S PSDOUT=0,PSDATE=$$FMTE^XLFDT(PSDBD),PEDATE=$$FMTE^XLFDT(PSDED)
I '$D(^TMP("PSDSUBOX",$J)) D HD W !,?25,"***NO DATA FOUND FOR SELECTION***",!! D HD1^PSDDSOR I $D(DIRUT) Q
S DIV=0 F S DIV=$O(^TMP("PSDSUBOX",$J,DIV)) Q:'DIV D I PSDOUT Q
.D HD,PGCHK I PSDOUT Q
.S PRV="" F S PRV=$O(^TMP("PSDSUBOX",$J,DIV,PRV)) Q:PRV="" D I PSDOUT Q
..I RPTYP="S" W !,$$GET1^DIQ(200,$P(PRV,"^",2),.01),?60,$G(^TMP("PSDSUBOXC",$J,DIV,PRV))
..S DRG="" F S DRG=$O(^TMP("PSDSUBOX",$J,DIV,PRV,DRG)) Q:DRG="" D I PSDOUT Q
...D PRT1 Q:PSDOUT D PGCHK
..I RPTYP="S" W !
Q
;
PRT1 ;print report details
N ND0,LIN,DFN,PL,EE
;/BLB/ PSD*83 - ADDED NEW COUNTER TO CORRECTLY COUNT PATIENTS PRESCRIBED SUBOXONE
I RPTYP="S" W !?3,$P(DRG,"^") Q
S RXN=0 F S RXN=$O(^TMP("PSDSUBOX",$J,DIV,PRV,DRG,RXN)) Q:'RXN D Q:PSDOUT
.S ND0=$G(^PSRX(RXN,0)),DFN=$P(ND0,"^",2)
.W ?2,"Issue Date: ",$$FMTE^XLFDT($P(ND0,"^",13))
.D DEM^VADPT,ADD^VADPT
.W !?2,"Patient: ",VADM(1)
.W !?2,VAPA(1),$S(VAPA(2)'="":", "_VAPA(2),1:"")
.I VAPA(3)'="" W !?2,VAPA(3)
.W !?2,$S(VAPA(4)'="":VAPA(4)_", ",1:""),$P(VAPA(5),"^",2)," ",VAPA(6)
.D PGCHK I PSDOUT Q
.W !!?2,$$GET1^DIQ(50,$P(DRG,"^",2),.01),?50,"Qty: ",$P(ND0,"^",7),?60,"# of Refills: ",$P(ND0,"^",9)
.D FSIG^PSDDSOR1("R",RXN,75)
.I $G(FSIG(1))'="" D
..W !?2,"SIG: ",$$UNESC^ORHLESC($G(FSIG(1)))
..I $O(FSIG(1)) D
...F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE D
....W !?6,$$UNESC^ORHLESC($G(FSIG(EE)))
.D PGCHK I PSDOUT Q
.W !!?2,"Provider: ",$$GET1^DIQ(200,$P(ND0,"^",4),.01),!
.D VADR($$GET1^DIQ(52,RXN,39.3,"I"),.VADR)
.I $D(VADR(1)) W ?2,$P(VADR(1),"^"),!?2,VADR(2),!?2,VADR(3),!
.F LIN=1:1:80 W "="
.D PGCHK I PSDOUT Q
; PSD*3.0*83 - cleaning up FSIG
K FSIG,VADM,VADR,VAPA
Q
HD ;header
N DVL,DVN,LIN
W @IOF,?22,"DEA DATA-Waived Practitioner Report",?67,DTM,!,?32,$S(RPTYP="D":"Detailed",1:"Summary")_" Report"
S DVN=$P($G(^PS(59,+$G(DIV),0)),"^",1),DVL=80-(9+$L(DVN))/2
I DVN'="" W !?DVL,"DIVISION: ",DVN
W !?26,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!
I RPTYP="S" W !,"PROVIDER/DRUG",?55,"# OF PATIENTS",!
F LIN=1:1:80 W "-"
S PG=PG+1
Q
PGCHK ;check for page break
I ($Y+4)>IOSL D Q
.W ! D HD1^PSDDSOR I $D(DIRUT) S PSDOUT=1 Q
.D HD W !
Q
;
DIVSEL(ARY) ;Division selection (one, multiple or ALL)
N DIC,DTOUT,DUOUT,QF,Y,X
W !!,?5,"You may select a single or multiple Divisions,"
W !,?5,"or enter ^ALL to select all Divisions.",!
S DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
S DIC="^PS(59,",DIC(0)="QEZAM",DIC("A")="Division: ",QF=0
F D ^DIC Q:X="" D Q:QF
.I $$UP^XLFSTR(X)="^ALL" K ARY S ARY="^ALL",QF=1 Q
.I $D(DTOUT)!$D(DUOUT) K ARY S ARY="^",QF=1 Q
.W " ",$P(Y,"^",2),$S($D(ARY(+Y)):" (already selected)",1:"")
.W ! S ARY(+Y)=""
I '$D(ARY) S ARY="^"
Q
VADR(ORN,VADD) ;Get Provider's Address
;ORN: Order IEN (Pointer to file #100)
K ^TMP($J,"ORDEA"),VADD
D ARCHIVE^ORDEA(ORN)
I $D(^TMP($J,"ORDEA",ORN,3)) S VADD=^(3) D
.I $P(VADD,"^",2)="" Q
.S VADD(1)=$P(VADD,"^",2),VADD(2)=$P(VADD,"^",3)
.S VADD(3)=$P(VADD,"^",4)_", "_$P(VADD,"^",5)_" "_$P(VADD,"^",6)
K ^TMP($J,"ORDEA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDSUBOX 6346 printed Apr 09, 2024@20:54:26 Page 2
PSDSUBOX ;BHAM ISC/JAM - DEA DATA - Waived Practitioner Report ;05 July 2011 5:30 pm
+1 ;;3.0;CONTROLLED SUBSTANCES;**73,83**;13 Feb 97;Build 10
+2 ;External reference to ^PS(59 supported by DBIA #2621
+3 ;External reference to ^PSRX( supported by DBIA #1977
+4 ;External reference to ^PSDRUG( supported by DBIA #221
+5 ;
+6 ;ask division/site
+7 NEW PSDIV,PSPRV,RPTYP,PSDED,PSDBD,PSDSD
+8 DO DIVSEL(.PSDIV)
IF $GET(PSDIV)="^"
GOTO EXIT
+9 IF $GET(PSDIV)="^ALL"
SET PSDIV=0
FOR
SET PSDIV=$ORDER(^PS(59,PSDIV))
if 'PSDIV
QUIT
IF $SELECT('$DATA(^PS(59,+PSDIV,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
SET PSDIV(PSDIV)=""
+10 IF '$DATA(PSDIV)
GOTO EXIT
+11 ;
DATE ;ask date range
+1 WRITE !
KILL %DT
SET %DT(0)=-DT
SET %DT="AEP"
SET %DT("A")="Start Date: "
DO ^%DT
+2 IF Y<0!($DATA(DTOUT))
GOTO EXIT
+3 SET (%DT(0),PSDBD)=Y
SET %DT("A")="End Date: "
+4 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
GOTO EXIT
+5 SET PSDED=Y
SET PSDSD=PSDBD-.000001
PRV ;ask provider(s)
+1 WRITE !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
+2 KILL PRV,DIC
SET DIC("A")="Select Provider: "
SET DIC=200
SET DIC(0)="QEAM"
+3 SET DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
+4 FOR
DO ^DIC
if +Y<0
QUIT
SET PSPRV(+Y)=""
+5 KILL DIC
IF $$UP^XLFSTR(X)="^ALL"
KILL DUOUT
GOTO TYP
+6 IF ($DATA(DUOUT))!($DATA(DTOUT))
GOTO EXIT
+7 IF '$DATA(PSPRV)&(Y<0)
GOTO PRV
TYP ;ask report selection - detail or summary
+1 SET DIR(0)="SA^D:Detailed;S:Summary"
SET DIR("A")="Detailed/Summary Report: "
SET DIR("B")="D"
+2 DO ^DIR
+3 IF $DATA(DIRUT)
GOTO EXIT
+4 SET RPTYP=Y
+5 WRITE !
KILL %ZIS,IOP,IO("Q"),POP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
WRITE !!,"NO DEVICE SELECTED OR REPORT PRINTED!!",!
KILL IOP
GOTO EXIT
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="RPT^PSDSUBOX"
SET ZTDESC="DEA Waived Practitioner Report"
SET ZTSAVE("PSDIV(")=""
SET ZTSAVE("PSPRV(")=""
+8 FOR G="PSDSD","PSDED","PSDBD","RPTYP"
if $DATA(@G)
SET ZTSAVE(G)=""
+9 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report Queued to Print !!",!
DO HOME^%ZIS
KILL ZTSK,IO("Q")
End DoDot:1
GOTO EXIT
+10 USE IO
+11 ;
RPT ;generate report
+1 NEW RXN,ND0,ND2,DRGDA,DRGNM,DEA,DIV,PRVDA,PRVNM,PG,DTM,PATIEN
+2 SET PG=1
SET DTM=$$FMTE^XLFDT(DT)
+3 KILL ^TMP("PSDSUBOX",$JOB),^TMP("PSDSUBOXC",$JOB)
+4 FOR
SET PSDSD=$ORDER(^PSRX("AFDT",PSDSD))
if 'PSDSD!(PSDSD>(PSDED+.99))
QUIT
Begin DoDot:1
+5 SET RXN=0
FOR
SET RXN=$ORDER(^PSRX("AFDT",PSDSD,RXN))
if 'RXN
QUIT
Begin DoDot:2
+6 SET ND0=$GET(^PSRX(RXN,0))
SET DRGDA=$PIECE(ND0,"^",6)
SET DRGNM=$$GET1^DIQ(50,DRGDA,.01)
SET DEA=$$GET1^DIQ(50,DRGDA,3)
SET PATIEN=$PIECE(ND0,U,2)
+7 if DEA<1
QUIT
if DEA>5
QUIT
if '$$DETOX^PSSOPKI(DRGDA)
QUIT
+8 SET ND2=$GET(^PSRX(RXN,2))
SET DIV=$PIECE(ND2,"^",9)
SET PRVDA=$PIECE(ND0,"^",4)
SET PRVNM=$$GET1^DIQ(59,PRVDA,.01)
+9 IF '$DATA(PSDIV(+DIV))
QUIT
+10 IF $DATA(PSPRV)
IF '$DATA(PSPRV(+PRVDA))
QUIT
+11 DO SETMP
End DoDot:2
End DoDot:1
+12 DO PRT
+13 ;
EXIT DO ^%ZISC
KILL PG,G,DR,X,Y,DIR,DIRUT,DUOUT,I,Y,DIC,DTOUT,%DT
+1 KILL ZTDESC,ZTRTN,ZTSAVE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTQUEUED
DO KVA^VADPT
+2 QUIT
+3 ;
SETMP ;set ^TMP("PSDSUBOX",$J global
+1 NEW DRUGINFO,PROVIEN
+2 SET DRUGINFO=$EXTRACT(DRGNM,1,50)_"^"_DRGDA
+3 SET PROVIEN=$EXTRACT(PRVNM,1,50)_"^"_PRVDA
+4 ;S ^TMP("PSDSUBOX",$J,DIV,DRUGINFO,PROVIEN)=$G(^TMP("PSDSUBOX",$J,DIV,DRUGINFO,PROVIEN))+1
+5 SET ^TMP("PSDSUBOX",$JOB,DIV,PROVIEN,DRUGINFO,RXN)=""
+6 IF '$DATA(^TMP("PSDSUBOXC",$JOB,DIV,PROVIEN,PATIEN))
Begin DoDot:1
+7 SET ^TMP("PSDSUBOXC",$JOB,DIV,PROVIEN,PATIEN)=""
+8 SET ^TMP("PSDSUBOXC",$JOB,DIV,PROVIEN)=$GET(^TMP("PSDSUBOXC",$JOB,DIV,PROVIEN))+1
End DoDot:1
+9 QUIT
+10 ;
PRT ;prints report
+1 NEW DIV,DRG,PRV,PSDATE,PEDATE,PSDOUT
+2 SET PSDOUT=0
SET PSDATE=$$FMTE^XLFDT(PSDBD)
SET PEDATE=$$FMTE^XLFDT(PSDED)
+3 IF '$DATA(^TMP("PSDSUBOX",$JOB))
DO HD
WRITE !,?25,"***NO DATA FOUND FOR SELECTION***",!!
DO HD1^PSDDSOR
IF $DATA(DIRUT)
QUIT
+4 SET DIV=0
FOR
SET DIV=$ORDER(^TMP("PSDSUBOX",$JOB,DIV))
if 'DIV
QUIT
Begin DoDot:1
+5 DO HD
DO PGCHK
IF PSDOUT
QUIT
+6 SET PRV=""
FOR
SET PRV=$ORDER(^TMP("PSDSUBOX",$JOB,DIV,PRV))
if PRV=""
QUIT
Begin DoDot:2
+7 IF RPTYP="S"
WRITE !,$$GET1^DIQ(200,$PIECE(PRV,"^",2),.01),?60,$GET(^TMP("PSDSUBOXC",$JOB,DIV,PRV))
+8 SET DRG=""
FOR
SET DRG=$ORDER(^TMP("PSDSUBOX",$JOB,DIV,PRV,DRG))
if DRG=""
QUIT
Begin DoDot:3
+9 DO PRT1
if PSDOUT
QUIT
DO PGCHK
End DoDot:3
IF PSDOUT
QUIT
+10 IF RPTYP="S"
WRITE !
End DoDot:2
IF PSDOUT
QUIT
End DoDot:1
IF PSDOUT
QUIT
+11 QUIT
+12 ;
PRT1 ;print report details
+1 NEW ND0,LIN,DFN,PL,EE
+2 ;/BLB/ PSD*83 - ADDED NEW COUNTER TO CORRECTLY COUNT PATIENTS PRESCRIBED SUBOXONE
+3 IF RPTYP="S"
WRITE !?3,$PIECE(DRG,"^")
QUIT
+4 SET RXN=0
FOR
SET RXN=$ORDER(^TMP("PSDSUBOX",$JOB,DIV,PRV,DRG,RXN))
if 'RXN
QUIT
Begin DoDot:1
+5 SET ND0=$GET(^PSRX(RXN,0))
SET DFN=$PIECE(ND0,"^",2)
+6 WRITE ?2,"Issue Date: ",$$FMTE^XLFDT($PIECE(ND0,"^",13))
+7 DO DEM^VADPT
DO ADD^VADPT
+8 WRITE !?2,"Patient: ",VADM(1)
+9 WRITE !?2,VAPA(1),$SELECT(VAPA(2)'="":", "_VAPA(2),1:"")
+10 IF VAPA(3)'=""
WRITE !?2,VAPA(3)
+11 WRITE !?2,$SELECT(VAPA(4)'="":VAPA(4)_", ",1:""),$PIECE(VAPA(5),"^",2)," ",VAPA(6)
+12 DO PGCHK
IF PSDOUT
QUIT
+13 WRITE !!?2,$$GET1^DIQ(50,$PIECE(DRG,"^",2),.01),?50,"Qty: ",$PIECE(ND0,"^",7),?60,"# of Refills: ",$PIECE(ND0,"^",9)
+14 DO FSIG^PSDDSOR1("R",RXN,75)
+15 IF $GET(FSIG(1))'=""
Begin DoDot:2
+16 WRITE !?2,"SIG: ",$$UNESC^ORHLESC($GET(FSIG(1)))
+17 IF $ORDER(FSIG(1))
Begin DoDot:3
+18 FOR EE=1:0
SET EE=$ORDER(FSIG(EE))
if 'EE
QUIT
Begin DoDot:4
+19 WRITE !?6,$$UNESC^ORHLESC($GET(FSIG(EE)))
End DoDot:4
End DoDot:3
End DoDot:2
+20 DO PGCHK
IF PSDOUT
QUIT
+21 WRITE !!?2,"Provider: ",$$GET1^DIQ(200,$PIECE(ND0,"^",4),.01),!
+22 DO VADR($$GET1^DIQ(52,RXN,39.3,"I"),.VADR)
+23 IF $DATA(VADR(1))
WRITE ?2,$PIECE(VADR(1),"^"),!?2,VADR(2),!?2,VADR(3),!
+24 FOR LIN=1:1:80
WRITE "="
+25 DO PGCHK
IF PSDOUT
QUIT
End DoDot:1
if PSDOUT
QUIT
+26 ; PSD*3.0*83 - cleaning up FSIG
+27 KILL FSIG,VADM,VADR,VAPA
+28 QUIT
HD ;header
+1 NEW DVL,DVN,LIN
+2 WRITE @IOF,?22,"DEA DATA-Waived Practitioner Report",?67,DTM,!,?32,$SELECT(RPTYP="D":"Detailed",1:"Summary")_" Report"
+3 SET DVN=$PIECE($GET(^PS(59,+$GET(DIV),0)),"^",1)
SET DVL=80-(9+$LENGTH(DVN))/2
+4 IF DVN'=""
WRITE !?DVL,"DIVISION: ",DVN
+5 WRITE !?26,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!
+6 IF RPTYP="S"
WRITE !,"PROVIDER/DRUG",?55,"# OF PATIENTS",!
+7 FOR LIN=1:1:80
WRITE "-"
+8 SET PG=PG+1
+9 QUIT
PGCHK ;check for page break
+1 IF ($Y+4)>IOSL
Begin DoDot:1
+2 WRITE !
DO HD1^PSDDSOR
IF $DATA(DIRUT)
SET PSDOUT=1
QUIT
+3 DO HD
WRITE !
End DoDot:1
QUIT
+4 QUIT
+5 ;
DIVSEL(ARY) ;Division selection (one, multiple or ALL)
+1 NEW DIC,DTOUT,DUOUT,QF,Y,X
+2 WRITE !!,?5,"You may select a single or multiple Divisions,"
+3 WRITE !,?5,"or enter ^ALL to select all Divisions.",!
+4 SET DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
+5 SET DIC="^PS(59,"
SET DIC(0)="QEZAM"
SET DIC("A")="Division: "
SET QF=0
+6 FOR
DO ^DIC
if X=""
QUIT
Begin DoDot:1
+7 IF $$UP^XLFSTR(X)="^ALL"
KILL ARY
SET ARY="^ALL"
SET QF=1
QUIT
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL ARY
SET ARY="^"
SET QF=1
QUIT
+9 WRITE " ",$PIECE(Y,"^",2),$SELECT($DATA(ARY(+Y)):" (already selected)",1:"")
+10 WRITE !
SET ARY(+Y)=""
End DoDot:1
if QF
QUIT
+11 IF '$DATA(ARY)
SET ARY="^"
+12 QUIT
VADR(ORN,VADD) ;Get Provider's Address
+1 ;ORN: Order IEN (Pointer to file #100)
+2 KILL ^TMP($JOB,"ORDEA"),VADD
+3 DO ARCHIVE^ORDEA(ORN)
+4 IF $DATA(^TMP($JOB,"ORDEA",ORN,3))
SET VADD=^(3)
Begin DoDot:1
+5 IF $PIECE(VADD,"^",2)=""
QUIT
+6 SET VADD(1)=$PIECE(VADD,"^",2)
SET VADD(2)=$PIECE(VADD,"^",3)
+7 SET VADD(3)=$PIECE(VADD,"^",4)_", "_$PIECE(VADD,"^",5)_" "_$PIECE(VADD,"^",6)
End DoDot:1
+8 KILL ^TMP($JOB,"ORDEA")
+9 QUIT
