- 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 23, 2025@18:03:30 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
