ORDEA01A ;ISP/RFR - DEA REPORTS 01;10/15/2014 08:03
;;3.0;ORDER ENTRY/RESULTS REPORTING;**218,350,499**;Dec 17, 1997;Build 165
Q
DUPVA ;DUPLICATE VA#'S REPORT
;REP IS HANDLED BY REPORTS^ORDEA01
N DISINC,DIV,SAVE
W !!,"This report identifies all users with similar VA numbers. To identify",!
W "similar numbers, the software builds a temporary index. First, it removes all",!
W "non-alphanumeric characters (such as punctuation and spaces) from the user's",!
W "VA number, then changes all letters to uppercase, and finally adds the VA",!
W "number to the temporary index. It then uses that index to build a list of",!
W "similar or duplicate numbers. For example, kc123, KC 123, and KC-123 are",!
W "considered similar.",!
S DISINC=$$DISPRMPT^ORDEA01()
Q:DISINC=U
S SAVE("DISINC")=""
D DEVICE^ORUTL($P(REP(REP),";",3),"OR "_$$UP^XLFSTR($P(REP(REP),";")),"Q",.SAVE)
Q
DUPVAQ ;TASKMAN ENTRY POINT
;CBUFFER IS HANDLED BY DEVICE^ORUTL OR TASKMAN
N DOCS,ERROR,KEY,INDEX,NUMBER,DUPL,PGNUM,COL,STOP,OUTPUT
;RETRIEVE ALL USERS WITH A VA #
S DOCS=$NA(^TMP($J,"ORDUPVA")),DUPL=$NA(^TMP($J,"ORDUPVA","DUPL"))
K @DOCS
D LIST^DIC(200,,"@;.01;53.3","PQ",,,,"PS2",,,DOCS,"ERROR")
I $D(ERROR) D Q
.D FMERROR^ORUTL(.ERROR)
.S:$D(ZTQUEUED) ZTREQ="@"
;ORDER THE RETURNED LIST BY VA #
S INDEX=0 F S INDEX=$O(@DOCS@("DILIST",INDEX)) Q:+$G(INDEX)=0 D
.S NUMBER=$P(@DOCS@("DILIST",INDEX,0),U,3),KEY=$$UP^XLFSTR(NUMBER)
.S KEY=$$STRIP(KEY)
.Q:$G(KEY)=""
.N ACCOUNT S ACCOUNT=$$ACTIVE^XUSER($P(@DOCS@("DILIST",INDEX,0),U))
.I 'DISINC,(+ACCOUNT<1),($P(ACCOUNT,U,2)'="") Q
.S ACCOUNT("TEXT")=$S($P(ACCOUNT,U,2)'="":$P(ACCOUNT,U,2),ACCOUNT=0:"CANNOT SIGN ON",1:"UNKNOWN")
.S @DUPL@(KEY)=+$G(@DUPL@(KEY))+1
.S @DUPL@(KEY,@DUPL@(KEY),NUMBER)=$$LJ^XLFSTR($P(@DOCS@("DILIST",INDEX,0),U,2),37," ")_ACCOUNT("TEXT")
;OUTPUT THE DUPLICATES
S COL(1)=$$LJ^XLFSTR("VA#",12," ")_$$LJ^XLFSTR("NAME",37," ")_"ACCOUNT STATUS"
S KEY="" F S KEY=$O(@DUPL@(KEY)) Q:$G(KEY)=""!($G(STOP)) D
.I @DUPL@(KEY)>1 D
..S OUTPUT=1
..I (@DUPL@(KEY)+$Y+CBUFFER)>IOSL!($Y=0) S STOP=$$HEADER^ORUTL("NON-UNIQUE VA NUMBERS REPORT",.PGNUM,.COL)
..Q:$G(STOP)
..S INDEX=0 F S INDEX=$O(@DUPL@(KEY,INDEX)) Q:+$G(INDEX)=0 D
...S NUMBER=$O(@DUPL@(KEY,INDEX,""))
...W $$LJ^XLFSTR(NUMBER,12," ")_@DUPL@(KEY,INDEX,NUMBER)
...I ($Y+1)<IOSL W !
..W $$REPEAT^XLFSTR("=",60)
..I ($Y+1)<IOSL W !
I '$G(STOP) D
.I '$G(OUTPUT) D Q:$G(STOP)
..S STOP=$$HEADER^ORUTL("NON-UNIQUE VA NUMBERS REPORT",.PGNUM,.COL)
..Q:STOP
..W !,$$CJ^XLFSTR("All VA Numbers are unique.",$S(+$G(IOM)>0:(IOM-1),1:79)," "),!
.I ($Y+2)>IOSL S STOP=$$HEADER^ORUTL("NON-UNIQUE VA NUMBERS REPORT",.PGNUM,.COL)
.Q:$G(STOP)
.W !,$$CJ^XLFSTR("[END OF REPORT]",$S(+$G(IOM)>0:(IOM-1),1:79)," ")
S:$D(ZTQUEUED) ZTREQ="@"
Q
STRIP(TEXT) ;REMOVE PUNCTUATION CHARACTERS AND SPACES
N %
F %=1:1:$L(TEXT) N CHR S CHR=$A($E(TEXT,%)) I CHR<48!(CHR>57&(CHR<65))!(CHR>90&(CHR<97))!(CHR>122) S TEXT=$TR(TEXT,$E(TEXT,%))
Q TEXT
INCOMPL ;INCOMPLETE PROVIDER SETUP REPORT
;REP IS HANDLED BY REPORTS^ORDEA01
W !!,"This report identifies all active providers who are unable to sign controlled",!
W "substance orders. For the purposes of this report, a provider is a user who",!
W "holds the ORES security key.",!
W !,"By default, the report lists the prescribable schedules for each provider",!
W "(including those providers that are properly configured).",!
N INCLUDE,DISINC,DIV,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,SAVE,ORCSV
S DIR(0)="Y"_U,DIR("A")="Do you want to include prescribable schedules in the output"
S DIR("B")="NO"
S DIR("?",1)="By answering YES, the report will list the schedules each provider is able to"
S DIR("?",2)="prescribe and will include those providers who are able to sign controlled"
S DIR("?",3)="substance orders."
S DIR("?",4)="By answering NO, the report will not list the prescribable schedules and will"
S DIR("?",5)="only include those providers who are unable to sign controlled substance"
S DIR("?")="orders."
D ^DIR
Q:$D(DIRUT)
S INCLUDE=Y
K X,Y,DTOUT,DUOUT,DIRUT,DIROUT
W !
S DISINC=$$DISPRMPT^ORDEA01()
Q:DISINC=U
W !
S X=$$DIVPRMPT^ORUTL(.DIV)
Q:X<1
K X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="Y"_U,DIR("A",1)="Do you want to generate the report in a delimited format suitable for import"
S DIR("A")="into third-party applications"
S DIR("?",1)="By answering YES, the report is generated in a comma-separated values (CSV)"
S DIR("?",2)="format."
S DIR("?")="By answering NO, the report is generated in a non-delimited format."
W !
D ^DIR
Q:$D(DIRUT)
S ORCSV=Y
I ORCSV D
.W !!,"To create a file on your computer for use in third-party applications, perform"
.W !,"the following:",!
.W !," 1. To queue the report, at the DEVICE: prompt, enter the letter Q."
.W !," 2. At the DEVICE: prompt, select the appropriate spooler device."
.W !," 3. Once the spooled document is ready, use option Download a Spool file entry"
.W !," [XT-KERMIT SPOOL DL] to download the report to your computer."
.W !," Note: Refer to your terminal emulator's documentation for instructions on"
.W !," receiving files via the KERMIT protocol.",!
S SAVE("INCLUDE")="",SAVE("DISINC")="",SAVE("DIV(")="",SAVE("ORCSV")=""
D DEVICE^ORUTL($P(REP(REP),";",3),"OR "_$$UP^XLFSTR($P(REP(REP),";")),"Q",.SAVE)
Q
INCOMPLQ ;TASKMAN ENTRY POINT
;CBUFFER IS HANDLED BY DEVICE^ORUTL OR TASKMAN
N DATA,Y,INDENT,STOP,COUNT
S DATA=$NA(^TMP($J,"ORDATA"))
K @DATA
S INDENT(0)=$$REPEAT^XLFSTR(" ",37),INDENT(1)=$$REPEAT^XLFSTR("-",34)
;IA #10076
S Y=0 F S Y=$O(^XUSEC("ORES",Y)) Q:+$G(Y)=0!($G(STOP)) D
.N DIVISION S DIVISION=$$HASDIV^ORUTL(Y,.DIV)
.Q:$G(DIVISION)=""
.N ACCOUNT S ACCOUNT=$$ACTIVE^XUSER(Y)
.I 'DISINC,(+ACCOUNT<1),($P(ACCOUNT,U,2)'="") Q
.;INCLUDE USERS WHO CANNOT SIGN-ON IN ACTIVE LISTING
.S ACCOUNT=$S(ACCOUNT=0:1,ACCOUNT="":-1,1:ACCOUNT)
.N RETURN,STATUS
.S STATUS=$$VDEA^XUSER(.RETURN,Y),COUNT=1+$G(COUNT)
.S STATUS=$$CHKSWIT^ORDEA01(.RETURN,Y,STATUS)
.I $D(RETURN)>9 D
..N REASON,NAME,INDEX
..S NAME=$$GET1^DIQ(200,Y_",",.01)
..I NAME="",ACCOUNT=-1 S NAME="ACCOUNT #"_Y
..S @DATA@(DIVISION,STATUS,+ACCOUNT,NAME)=$$GET1^DIQ(200,Y_",",8)
..S REASON="" F S REASON=$O(RETURN(REASON)) Q:$G(REASON)="" D
...N TEXT
...I '$G(INCLUDE),(REASON["Is permitted") Q
...I STATUS=1,(REASON'["Is permitted") D
....S TEXT=$$LOW^XLFSTR($E(REASON,1,1))_$E(REASON,2,$L(REASON))
....S TEXT="Can sign controlled substance orders, however, the provider "_TEXT
...S INDEX=1+$G(INDEX),@DATA@(DIVISION,STATUS,+ACCOUNT,NAME,INDEX)=$S($G(TEXT)'="":$G(TEXT),1:REASON)
.I 'COUNT#100 S STOP=$$STOPTASK^ORUTL()
I 'ORCSV D IREPORT
I ORCSV D IEXPORT
K @DATA
S:$D(ZTQUEUED) ZTREQ="@"
Q
IREPORT ;CREATE NON-CSV FORMAT
N DIVISION,NAME,LINE,STATUS,TEXT,OUTPUT,ACCOUNT,COL,PGNUM
S DIVISION="" F S DIVISION=$O(@DATA@(DIVISION)) Q:$G(DIVISION)=""!($G(STOP)) D
.S COL(1)="DIVISION: "_DIVISION
.F STATUS=0:1:1 D Q:$G(STOP)
..I STATUS=1,('$G(INCLUDE)) Q
..Q:$D(@DATA@(DIVISION,STATUS))<10
..S TEXT=$S(STATUS=0:"un",1:"")_"able"
..S COL(2)=$$LJ^XLFSTR("PROVIDER NAME",37," ")
..S COL(3)=$$LJ^XLFSTR(" TITLE",37," ")_$S(TEXT="unable":"DEFICIENCY",1:"")
..S COL(3)=COL(3)_$S(TEXT="unable"&INCLUDE=1:"/",1:"")_$S(INCLUDE=1:"PRESCRIBABLE SCHEDULES",1:"")
..S STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
..Q:$G(STOP)
..F ACCOUNT=1:-1:-1 D Q:$G(STOP)
...Q:$D(@DATA@(DIVISION,STATUS,ACCOUNT))<10
...N BUFFER S BUFFER=@DATA@(DIVISION,STATUS,ACCOUNT,$O(@DATA@(DIVISION,STATUS,ACCOUNT,"")))
...S BUFFER=BUFFER+$S(ACCOUNT=0&($Y>4):3,ACCOUNT=0:2,1:0)
...I (BUFFER+$Y+CBUFFER)>IOSL!($Y=0) D Q:$G(STOP)
....S STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
...I ACCOUNT=0 D
....W:$Y>4 !
....W $$CJ^XLFSTR("*** DISUSERED/TERMINATED USERS ***",$S(+$G(IOM)>0:(IOM-1),1:79)," "),!
....W $$CJ^XLFSTR(INDENT(1),$S(+$G(IOM)>0:(IOM-1),1:79)," "),!
...S NAME="" F S NAME=$O(@DATA@(DIVISION,STATUS,ACCOUNT,NAME)) Q:$G(NAME)=""!($G(STOP)) D
....N BODY
....S INDEX=0 F S INDEX=$O(@DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX)) Q:'INDEX D
.....D WRAP^ORUTL(INDENT(0)_@DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX),"BODY")
....S BODY(1)=$$LJ^XLFSTR(NAME,37," ")_$E($G(BODY(1)),38,$S(+$G(IOM)>0:IOM,1:80))
....S BODY(2)=$$LJ^XLFSTR(" "_@DATA@(DIVISION,STATUS,ACCOUNT,NAME),37," ")_$E($G(BODY(2)),38,$S(+$G(IOM)>0:IOM,1:80))
....S:BODY<2 BODY=2
....I (BODY+$Y+CBUFFER)>IOSL D Q:$G(STOP)
.....S STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
....F LINE=1:1:BODY D
.....W BODY(LINE)
.....I ($Y+1)<IOSL W !
.....S OUTPUT=1
....I LINE>0,(($Y+1)<IOSL) W !
I '$G(STOP) D
.I '$G(OUTPUT) D Q:$G(STOP)
..S STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
..Q:STOP
..N TEXT,BODY
..S TEXT="All providers are able to sign controlled substance orders"
..I $D(DIV) D
...N IDX,STATIONS
...S IDX="" F S IDX=$O(DIV(IDX)) Q:$G(IDX)="" D
....N DELIMIT
....S DELIMIT=$S($O(DIV(IDX))'="":", ",1:" and ")
....S STATIONS=$S($G(STATIONS)'="":STATIONS_DELIMIT,1:"")_DIV(IDX)
...S TEXT=TEXT_" in "_STATIONS
..D WRAP^ORUTL(TEXT_".","BODY")
..S BODY=0 F S BODY=$O(BODY(BODY)) Q:'BODY W BODY(BODY),!
.I ($Y+2)>IOSL S STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
.Q:$G(STOP)
.W !,$$CJ^XLFSTR("[END OF REPORT]",$S(+$G(IOM)>0:(IOM-1),1:79)," ")
Q
IEXPORT ;CREATE CSV FORMAT
N DIVISION,STATUS,ACCOUNT,NAME,Q,QCQ,LINE,XTKDIC,XTKMODE,XTKFILE
S Q=$C(34),QCQ=Q_","_Q
W Q_"DIVISION"_QCQ_"PROVIDER NAME"_QCQ_"TITLE"_QCQ_"DEFICIENCY"
W $S(INCLUDE=1:"/PRESCRIBABLE SCHEDULES",1:"")_Q,!
S DIVISION="" F S DIVISION=$O(@DATA@(DIVISION)) Q:$G(DIVISION)="" D
.F STATUS=0:1:1 D
..I STATUS=1,('$G(INCLUDE)) Q
..F ACCOUNT=1:-1:0 D
...S NAME="" F S NAME=$O(@DATA@(DIVISION,STATUS,ACCOUNT,NAME)) Q:$G(NAME)="" D
....S INDEX=0 F S INDEX=$O(@DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX)) Q:$G(INDEX)="" D
.....W Q_DIVISION_QCQ_NAME_QCQ_@DATA@(DIVISION,STATUS,ACCOUNT,NAME)_QCQ
.....W @DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX)_Q,!
Q
DETOX ;DETOX/MAINTENANCE ID Report
;REP IS HANDLED BY REPORTS^ORDEA01
N DISINC
W !!,"This report identifies all users who have a DETOX/MAINTENANCE ID number",!
W "in the NEW PERSON FILE (#200).",!
S DISINC=$$DISPRMPT^ORDEA01()
Q:DISINC=U
S SAVE("DISINC")=""
D DEVICE^ORUTL($P(REP(REP),";",3),"OR "_$$UP^XLFSTR($P(REP(REP),";")),"Q",.SAVE)
Q
DETOXQ ;TASKMAN ENTRY POINT
;CBUFFER IS HANDLED BY DEVICE^ORUTL OR TASKMAN
N DOCS,DATA,ERROR,INDEX,PGNUM,COL,STOP,ACCOUNT,OUTPUT
;RETRIEVE ALL USERS WITH A DETOX/MAINTENANCE ID NUMBER
S DOCS=$NA(^TMP($J,"ORDETOX")),DATA=$NA(^TMP($J,"ORDETOXDATA"))
K @DOCS,@DATA
S COL(1)=" DETOX/MAINTENANCE"
S COL(2)="NAME ID NUMBER ACCOUNT STATUS"
;*499
D LIST^DIC(200,,"@;.01;9001","PQ",,,,,"I ($L($$DETOX^XUSER(Y)))",,DOCS,"ERROR")
I $D(ERROR) D Q
.D FMERROR^ORUTL(.ERROR)
.S:$D(ZTQUEUED) ZTREQ="@"
.K @DOCS
S INDEX=0 F S INDEX=$O(@DOCS@("DILIST",INDEX)) Q:+$G(INDEX)=0 D
.N ACCOUNT S ACCOUNT=$$ACTIVE^XUSER($P(@DOCS@("DILIST",INDEX,0),U))
.I 'DISINC,(+ACCOUNT<1),($P(ACCOUNT,U,2)'="") Q
.S ACCOUNT("TEXT")=$S($P(ACCOUNT,U,2)'="":$P(ACCOUNT,U,2),ACCOUNT=0:"CANNOT SIGN ON",1:"UNKNOWN")
.;INCLUDE USERS WHO CANNOT SIGN-ON IN ACTIVE LISTING
.I ACCOUNT=0 S ACCOUNT=1
.S @DATA@(+ACCOUNT,$P(@DOCS@("DILIST",INDEX,0),U,2))=$$LJ^XLFSTR($P(@DOCS@("DILIST",INDEX,0),U,3),19," ")_ACCOUNT("TEXT")
F ACCOUNT=1:-1:0 D Q:$G(STOP)
.Q:'$D(@DATA@(ACCOUNT))
.I ACCOUNT=0 D
..I ($Y+CBUFFER+4)>IOSL!($Y=0) D Q:$G(STOP)
...S STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
..W !,$$CJ^XLFSTR("*** DISUSERED/TERMINATED USERS ***",$S(+$G(IOM)>0:(IOM-1),1:79)," "),!
..W $$CJ^XLFSTR($$REPEAT^XLFSTR("-",34),$S(+$G(IOM)>0:IOM,1:80)," "),!
.S NAME="" F S NAME=$O(@DATA@(ACCOUNT,NAME)) Q:NAME=""!($G(STOP)) D
..I ($Y+CBUFFER)>IOSL!($Y=0) D Q:$G(STOP)
...S STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
..W $$LJ^XLFSTR(NAME,37," ")_@DATA@(ACCOUNT,NAME)
..I ($Y+1)<IOSL W !
..S OUTPUT=1
I '$G(STOP) D
.I '$G(OUTPUT) D Q:$G(STOP)
..S STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
..Q:STOP
..W !,$$CJ^XLFSTR("0 PROVIDERS FOUND",$S(+$G(IOM)>0:(IOM-1),1:79)," "),!
.I ($Y+2)>IOSL S STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
.Q:$G(STOP)
.W !,$$CJ^XLFSTR("[END OF REPORT]",$S(+$G(IOM)>0:(IOM-1),1:79)," ")
K @DOCS,@DATA
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDEA01A 12843 printed Sep 23, 2025@20:06:12 Page 2
ORDEA01A ;ISP/RFR - DEA REPORTS 01;10/15/2014 08:03
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**218,350,499**;Dec 17, 1997;Build 165
+2 QUIT
DUPVA ;DUPLICATE VA#'S REPORT
+1 ;REP IS HANDLED BY REPORTS^ORDEA01
+2 NEW DISINC,DIV,SAVE
+3 WRITE !!,"This report identifies all users with similar VA numbers. To identify",!
+4 WRITE "similar numbers, the software builds a temporary index. First, it removes all",!
+5 WRITE "non-alphanumeric characters (such as punctuation and spaces) from the user's",!
+6 WRITE "VA number, then changes all letters to uppercase, and finally adds the VA",!
+7 WRITE "number to the temporary index. It then uses that index to build a list of",!
+8 WRITE "similar or duplicate numbers. For example, kc123, KC 123, and KC-123 are",!
+9 WRITE "considered similar.",!
+10 SET DISINC=$$DISPRMPT^ORDEA01()
+11 if DISINC=U
QUIT
+12 SET SAVE("DISINC")=""
+13 DO DEVICE^ORUTL($PIECE(REP(REP),";",3),"OR "_$$UP^XLFSTR($PIECE(REP(REP),";")),"Q",.SAVE)
+14 QUIT
DUPVAQ ;TASKMAN ENTRY POINT
+1 ;CBUFFER IS HANDLED BY DEVICE^ORUTL OR TASKMAN
+2 NEW DOCS,ERROR,KEY,INDEX,NUMBER,DUPL,PGNUM,COL,STOP,OUTPUT
+3 ;RETRIEVE ALL USERS WITH A VA #
+4 SET DOCS=$NAME(^TMP($JOB,"ORDUPVA"))
SET DUPL=$NAME(^TMP($JOB,"ORDUPVA","DUPL"))
+5 KILL @DOCS
+6 DO LIST^DIC(200,,"@;.01;53.3","PQ",,,,"PS2",,,DOCS,"ERROR")
+7 IF $DATA(ERROR)
Begin DoDot:1
+8 DO FMERROR^ORUTL(.ERROR)
+9 if $DATA(ZTQUEUED)
SET ZTREQ="@"
End DoDot:1
QUIT
+10 ;ORDER THE RETURNED LIST BY VA #
+11 SET INDEX=0
FOR
SET INDEX=$ORDER(@DOCS@("DILIST",INDEX))
if +$GET(INDEX)=0
QUIT
Begin DoDot:1
+12 SET NUMBER=$PIECE(@DOCS@("DILIST",INDEX,0),U,3)
SET KEY=$$UP^XLFSTR(NUMBER)
+13 SET KEY=$$STRIP(KEY)
+14 if $GET(KEY)=""
QUIT
+15 NEW ACCOUNT
SET ACCOUNT=$$ACTIVE^XUSER($PIECE(@DOCS@("DILIST",INDEX,0),U))
+16 IF 'DISINC
IF (+ACCOUNT<1)
IF ($PIECE(ACCOUNT,U,2)'="")
QUIT
+17 SET ACCOUNT("TEXT")=$SELECT($PIECE(ACCOUNT,U,2)'="":$PIECE(ACCOUNT,U,2),ACCOUNT=0:"CANNOT SIGN ON",1:"UNKNOWN")
+18 SET @DUPL@(KEY)=+$GET(@DUPL@(KEY))+1
+19 SET @DUPL@(KEY,@DUPL@(KEY),NUMBER)=$$LJ^XLFSTR($PIECE(@DOCS@("DILIST",INDEX,0),U,2),37," ")_ACCOUNT("TEXT")
End DoDot:1
+20 ;OUTPUT THE DUPLICATES
+21 SET COL(1)=$$LJ^XLFSTR("VA#",12," ")_$$LJ^XLFSTR("NAME",37," ")_"ACCOUNT STATUS"
+22 SET KEY=""
FOR
SET KEY=$ORDER(@DUPL@(KEY))
if $GET(KEY)=""!($GET(STOP))
QUIT
Begin DoDot:1
+23 IF @DUPL@(KEY)>1
Begin DoDot:2
+24 SET OUTPUT=1
+25 IF (@DUPL@(KEY)+$Y+CBUFFER)>IOSL!($Y=0)
SET STOP=$$HEADER^ORUTL("NON-UNIQUE VA NUMBERS REPORT",.PGNUM,.COL)
+26 if $GET(STOP)
QUIT
+27 SET INDEX=0
FOR
SET INDEX=$ORDER(@DUPL@(KEY,INDEX))
if +$GET(INDEX)=0
QUIT
Begin DoDot:3
+28 SET NUMBER=$ORDER(@DUPL@(KEY,INDEX,""))
+29 WRITE $$LJ^XLFSTR(NUMBER,12," ")_@DUPL@(KEY,INDEX,NUMBER)
+30 IF ($Y+1)<IOSL
WRITE !
End DoDot:3
+31 WRITE $$REPEAT^XLFSTR("=",60)
+32 IF ($Y+1)<IOSL
WRITE !
End DoDot:2
End DoDot:1
+33 IF '$GET(STOP)
Begin DoDot:1
+34 IF '$GET(OUTPUT)
Begin DoDot:2
+35 SET STOP=$$HEADER^ORUTL("NON-UNIQUE VA NUMBERS REPORT",.PGNUM,.COL)
+36 if STOP
QUIT
+37 WRITE !,$$CJ^XLFSTR("All VA Numbers are unique.",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," "),!
End DoDot:2
if $GET(STOP)
QUIT
+38 IF ($Y+2)>IOSL
SET STOP=$$HEADER^ORUTL("NON-UNIQUE VA NUMBERS REPORT",.PGNUM,.COL)
+39 if $GET(STOP)
QUIT
+40 WRITE !,$$CJ^XLFSTR("[END OF REPORT]",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," ")
End DoDot:1
+41 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+42 QUIT
STRIP(TEXT) ;REMOVE PUNCTUATION CHARACTERS AND SPACES
+1 NEW %
+2 FOR %=1:1:$LENGTH(TEXT)
NEW CHR
SET CHR=$ASCII($EXTRACT(TEXT,%))
IF CHR<48!(CHR>57&(CHR<65))!(CHR>90&(CHR<97))!(CHR>122)
SET TEXT=$TRANSLATE(TEXT,$EXTRACT(TEXT,%))
+3 QUIT TEXT
INCOMPL ;INCOMPLETE PROVIDER SETUP REPORT
+1 ;REP IS HANDLED BY REPORTS^ORDEA01
+2 WRITE !!,"This report identifies all active providers who are unable to sign controlled",!
+3 WRITE "substance orders. For the purposes of this report, a provider is a user who",!
+4 WRITE "holds the ORES security key.",!
+5 WRITE !,"By default, the report lists the prescribable schedules for each provider",!
+6 WRITE "(including those providers that are properly configured).",!
+7 NEW INCLUDE,DISINC,DIV,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,SAVE,ORCSV
+8 SET DIR(0)="Y"_U
SET DIR("A")="Do you want to include prescribable schedules in the output"
+9 SET DIR("B")="NO"
+10 SET DIR("?",1)="By answering YES, the report will list the schedules each provider is able to"
+11 SET DIR("?",2)="prescribe and will include those providers who are able to sign controlled"
+12 SET DIR("?",3)="substance orders."
+13 SET DIR("?",4)="By answering NO, the report will not list the prescribable schedules and will"
+14 SET DIR("?",5)="only include those providers who are unable to sign controlled substance"
+15 SET DIR("?")="orders."
+16 DO ^DIR
+17 if $DATA(DIRUT)
QUIT
+18 SET INCLUDE=Y
+19 KILL X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+20 WRITE !
+21 SET DISINC=$$DISPRMPT^ORDEA01()
+22 if DISINC=U
QUIT
+23 WRITE !
+24 SET X=$$DIVPRMPT^ORUTL(.DIV)
+25 if X<1
QUIT
+26 KILL X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+27 SET DIR(0)="Y"_U
SET DIR("A",1)="Do you want to generate the report in a delimited format suitable for import"
+28 SET DIR("A")="into third-party applications"
+29 SET DIR("?",1)="By answering YES, the report is generated in a comma-separated values (CSV)"
+30 SET DIR("?",2)="format."
+31 SET DIR("?")="By answering NO, the report is generated in a non-delimited format."
+32 WRITE !
+33 DO ^DIR
+34 if $DATA(DIRUT)
QUIT
+35 SET ORCSV=Y
+36 IF ORCSV
Begin DoDot:1
+37 WRITE !!,"To create a file on your computer for use in third-party applications, perform"
+38 WRITE !,"the following:",!
+39 WRITE !," 1. To queue the report, at the DEVICE: prompt, enter the letter Q."
+40 WRITE !," 2. At the DEVICE: prompt, select the appropriate spooler device."
+41 WRITE !," 3. Once the spooled document is ready, use option Download a Spool file entry"
+42 WRITE !," [XT-KERMIT SPOOL DL] to download the report to your computer."
+43 WRITE !," Note: Refer to your terminal emulator's documentation for instructions on"
+44 WRITE !," receiving files via the KERMIT protocol.",!
End DoDot:1
+45 SET SAVE("INCLUDE")=""
SET SAVE("DISINC")=""
SET SAVE("DIV(")=""
SET SAVE("ORCSV")=""
+46 DO DEVICE^ORUTL($PIECE(REP(REP),";",3),"OR "_$$UP^XLFSTR($PIECE(REP(REP),";")),"Q",.SAVE)
+47 QUIT
INCOMPLQ ;TASKMAN ENTRY POINT
+1 ;CBUFFER IS HANDLED BY DEVICE^ORUTL OR TASKMAN
+2 NEW DATA,Y,INDENT,STOP,COUNT
+3 SET DATA=$NAME(^TMP($JOB,"ORDATA"))
+4 KILL @DATA
+5 SET INDENT(0)=$$REPEAT^XLFSTR(" ",37)
SET INDENT(1)=$$REPEAT^XLFSTR("-",34)
+6 ;IA #10076
+7 SET Y=0
FOR
SET Y=$ORDER(^XUSEC("ORES",Y))
if +$GET(Y)=0!($GET(STOP))
QUIT
Begin DoDot:1
+8 NEW DIVISION
SET DIVISION=$$HASDIV^ORUTL(Y,.DIV)
+9 if $GET(DIVISION)=""
QUIT
+10 NEW ACCOUNT
SET ACCOUNT=$$ACTIVE^XUSER(Y)
+11 IF 'DISINC
IF (+ACCOUNT<1)
IF ($PIECE(ACCOUNT,U,2)'="")
QUIT
+12 ;INCLUDE USERS WHO CANNOT SIGN-ON IN ACTIVE LISTING
+13 SET ACCOUNT=$SELECT(ACCOUNT=0:1,ACCOUNT="":-1,1:ACCOUNT)
+14 NEW RETURN,STATUS
+15 SET STATUS=$$VDEA^XUSER(.RETURN,Y)
SET COUNT=1+$GET(COUNT)
+16 SET STATUS=$$CHKSWIT^ORDEA01(.RETURN,Y,STATUS)
+17 IF $DATA(RETURN)>9
Begin DoDot:2
+18 NEW REASON,NAME,INDEX
+19 SET NAME=$$GET1^DIQ(200,Y_",",.01)
+20 IF NAME=""
IF ACCOUNT=-1
SET NAME="ACCOUNT #"_Y
+21 SET @DATA@(DIVISION,STATUS,+ACCOUNT,NAME)=$$GET1^DIQ(200,Y_",",8)
+22 SET REASON=""
FOR
SET REASON=$ORDER(RETURN(REASON))
if $GET(REASON)=""
QUIT
Begin DoDot:3
+23 NEW TEXT
+24 IF '$GET(INCLUDE)
IF (REASON["Is permitted")
QUIT
+25 IF STATUS=1
IF (REASON'["Is permitted")
Begin DoDot:4
+26 SET TEXT=$$LOW^XLFSTR($EXTRACT(REASON,1,1))_$EXTRACT(REASON,2,$LENGTH(REASON))
+27 SET TEXT="Can sign controlled substance orders, however, the provider "_TEXT
End DoDot:4
+28 SET INDEX=1+$GET(INDEX)
SET @DATA@(DIVISION,STATUS,+ACCOUNT,NAME,INDEX)=$SELECT($GET(TEXT)'="":$GET(TEXT),1:REASON)
End DoDot:3
End DoDot:2
+29 IF 'COUNT#100
SET STOP=$$STOPTASK^ORUTL()
End DoDot:1
+30 IF 'ORCSV
DO IREPORT
+31 IF ORCSV
DO IEXPORT
+32 KILL @DATA
+33 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+34 QUIT
IREPORT ;CREATE NON-CSV FORMAT
+1 NEW DIVISION,NAME,LINE,STATUS,TEXT,OUTPUT,ACCOUNT,COL,PGNUM
+2 SET DIVISION=""
FOR
SET DIVISION=$ORDER(@DATA@(DIVISION))
if $GET(DIVISION)=""!($GET(STOP))
QUIT
Begin DoDot:1
+3 SET COL(1)="DIVISION: "_DIVISION
+4 FOR STATUS=0:1:1
Begin DoDot:2
+5 IF STATUS=1
IF ('$GET(INCLUDE))
QUIT
+6 if $DATA(@DATA@(DIVISION,STATUS))<10
QUIT
+7 SET TEXT=$SELECT(STATUS=0:"un",1:"")_"able"
+8 SET COL(2)=$$LJ^XLFSTR("PROVIDER NAME",37," ")
+9 SET COL(3)=$$LJ^XLFSTR(" TITLE",37," ")_$SELECT(TEXT="unable":"DEFICIENCY",1:"")
+10 SET COL(3)=COL(3)_$SELECT(TEXT="unable"&INCLUDE=1:"/",1:"")_$SELECT(INCLUDE=1:"PRESCRIBABLE SCHEDULES",1:"")
+11 SET STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
+12 if $GET(STOP)
QUIT
+13 FOR ACCOUNT=1:-1:-1
Begin DoDot:3
+14 if $DATA(@DATA@(DIVISION,STATUS,ACCOUNT))<10
QUIT
+15 NEW BUFFER
SET BUFFER=@DATA@(DIVISION,STATUS,ACCOUNT,$ORDER(@DATA@(DIVISION,STATUS,ACCOUNT,"")))
+16 SET BUFFER=BUFFER+$SELECT(ACCOUNT=0&($Y>4):3,ACCOUNT=0:2,1:0)
+17 IF (BUFFER+$Y+CBUFFER)>IOSL!($Y=0)
Begin DoDot:4
+18 SET STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
End DoDot:4
if $GET(STOP)
QUIT
+19 IF ACCOUNT=0
Begin DoDot:4
+20 if $Y>4
WRITE !
+21 WRITE $$CJ^XLFSTR("*** DISUSERED/TERMINATED USERS ***",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," "),!
+22 WRITE $$CJ^XLFSTR(INDENT(1),$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," "),!
End DoDot:4
+23 SET NAME=""
FOR
SET NAME=$ORDER(@DATA@(DIVISION,STATUS,ACCOUNT,NAME))
if $GET(NAME)=""!($GET(STOP))
QUIT
Begin DoDot:4
+24 NEW BODY
+25 SET INDEX=0
FOR
SET INDEX=$ORDER(@DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX))
if 'INDEX
QUIT
Begin DoDot:5
+26 DO WRAP^ORUTL(INDENT(0)_@DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX),"BODY")
End DoDot:5
+27 SET BODY(1)=$$LJ^XLFSTR(NAME,37," ")_$EXTRACT($GET(BODY(1)),38,$SELECT(+$GET(IOM)>0:IOM,1:80))
+28 SET BODY(2)=$$LJ^XLFSTR(" "_@DATA@(DIVISION,STATUS,ACCOUNT,NAME),37," ")_$EXTRACT($GET(BODY(2)),38,$SELECT(+$GET(IOM)>0:IOM,1:80))
+29 if BODY<2
SET BODY=2
+30 IF (BODY+$Y+CBUFFER)>IOSL
Begin DoDot:5
+31 SET STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
End DoDot:5
if $GET(STOP)
QUIT
+32 FOR LINE=1:1:BODY
Begin DoDot:5
+33 WRITE BODY(LINE)
+34 IF ($Y+1)<IOSL
WRITE !
+35 SET OUTPUT=1
End DoDot:5
+36 IF LINE>0
IF (($Y+1)<IOSL)
WRITE !
End DoDot:4
End DoDot:3
if $GET(STOP)
QUIT
End DoDot:2
if $GET(STOP)
QUIT
End DoDot:1
+37 IF '$GET(STOP)
Begin DoDot:1
+38 IF '$GET(OUTPUT)
Begin DoDot:2
+39 SET STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
+40 if STOP
QUIT
+41 NEW TEXT,BODY
+42 SET TEXT="All providers are able to sign controlled substance orders"
+43 IF $DATA(DIV)
Begin DoDot:3
+44 NEW IDX,STATIONS
+45 SET IDX=""
FOR
SET IDX=$ORDER(DIV(IDX))
if $GET(IDX)=""
QUIT
Begin DoDot:4
+46 NEW DELIMIT
+47 SET DELIMIT=$SELECT($ORDER(DIV(IDX))'="":", ",1:" and ")
+48 SET STATIONS=$SELECT($GET(STATIONS)'="":STATIONS_DELIMIT,1:"")_DIV(IDX)
End DoDot:4
+49 SET TEXT=TEXT_" in "_STATIONS
End DoDot:3
+50 DO WRAP^ORUTL(TEXT_".","BODY")
+51 SET BODY=0
FOR
SET BODY=$ORDER(BODY(BODY))
if 'BODY
QUIT
WRITE BODY(BODY),!
End DoDot:2
if $GET(STOP)
QUIT
+52 IF ($Y+2)>IOSL
SET STOP=$$HEADER^ORUTL("PROVIDER INCOMPLETE CONFIGURATION REPORT",.PGNUM,.COL)
+53 if $GET(STOP)
QUIT
+54 WRITE !,$$CJ^XLFSTR("[END OF REPORT]",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," ")
End DoDot:1
+55 QUIT
IEXPORT ;CREATE CSV FORMAT
+1 NEW DIVISION,STATUS,ACCOUNT,NAME,Q,QCQ,LINE,XTKDIC,XTKMODE,XTKFILE
+2 SET Q=$CHAR(34)
SET QCQ=Q_","_Q
+3 WRITE Q_"DIVISION"_QCQ_"PROVIDER NAME"_QCQ_"TITLE"_QCQ_"DEFICIENCY"
+4 WRITE $SELECT(INCLUDE=1:"/PRESCRIBABLE SCHEDULES",1:"")_Q,!
+5 SET DIVISION=""
FOR
SET DIVISION=$ORDER(@DATA@(DIVISION))
if $GET(DIVISION)=""
QUIT
Begin DoDot:1
+6 FOR STATUS=0:1:1
Begin DoDot:2
+7 IF STATUS=1
IF ('$GET(INCLUDE))
QUIT
+8 FOR ACCOUNT=1:-1:0
Begin DoDot:3
+9 SET NAME=""
FOR
SET NAME=$ORDER(@DATA@(DIVISION,STATUS,ACCOUNT,NAME))
if $GET(NAME)=""
QUIT
Begin DoDot:4
+10 SET INDEX=0
FOR
SET INDEX=$ORDER(@DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX))
if $GET(INDEX)=""
QUIT
Begin DoDot:5
+11 WRITE Q_DIVISION_QCQ_NAME_QCQ_@DATA@(DIVISION,STATUS,ACCOUNT,NAME)_QCQ
+12 WRITE @DATA@(DIVISION,STATUS,ACCOUNT,NAME,INDEX)_Q,!
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
DETOX ;DETOX/MAINTENANCE ID Report
+1 ;REP IS HANDLED BY REPORTS^ORDEA01
+2 NEW DISINC
+3 WRITE !!,"This report identifies all users who have a DETOX/MAINTENANCE ID number",!
+4 WRITE "in the NEW PERSON FILE (#200).",!
+5 SET DISINC=$$DISPRMPT^ORDEA01()
+6 if DISINC=U
QUIT
+7 SET SAVE("DISINC")=""
+8 DO DEVICE^ORUTL($PIECE(REP(REP),";",3),"OR "_$$UP^XLFSTR($PIECE(REP(REP),";")),"Q",.SAVE)
+9 QUIT
DETOXQ ;TASKMAN ENTRY POINT
+1 ;CBUFFER IS HANDLED BY DEVICE^ORUTL OR TASKMAN
+2 NEW DOCS,DATA,ERROR,INDEX,PGNUM,COL,STOP,ACCOUNT,OUTPUT
+3 ;RETRIEVE ALL USERS WITH A DETOX/MAINTENANCE ID NUMBER
+4 SET DOCS=$NAME(^TMP($JOB,"ORDETOX"))
SET DATA=$NAME(^TMP($JOB,"ORDETOXDATA"))
+5 KILL @DOCS,@DATA
+6 SET COL(1)=" DETOX/MAINTENANCE"
+7 SET COL(2)="NAME ID NUMBER ACCOUNT STATUS"
+8 ;*499
+9 DO LIST^DIC(200,,"@;.01;9001","PQ",,,,,"I ($L($$DETOX^XUSER(Y)))",,DOCS,"ERROR")
+10 IF $DATA(ERROR)
Begin DoDot:1
+11 DO FMERROR^ORUTL(.ERROR)
+12 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+13 KILL @DOCS
End DoDot:1
QUIT
+14 SET INDEX=0
FOR
SET INDEX=$ORDER(@DOCS@("DILIST",INDEX))
if +$GET(INDEX)=0
QUIT
Begin DoDot:1
+15 NEW ACCOUNT
SET ACCOUNT=$$ACTIVE^XUSER($PIECE(@DOCS@("DILIST",INDEX,0),U))
+16 IF 'DISINC
IF (+ACCOUNT<1)
IF ($PIECE(ACCOUNT,U,2)'="")
QUIT
+17 SET ACCOUNT("TEXT")=$SELECT($PIECE(ACCOUNT,U,2)'="":$PIECE(ACCOUNT,U,2),ACCOUNT=0:"CANNOT SIGN ON",1:"UNKNOWN")
+18 ;INCLUDE USERS WHO CANNOT SIGN-ON IN ACTIVE LISTING
+19 IF ACCOUNT=0
SET ACCOUNT=1
+20 SET @DATA@(+ACCOUNT,$PIECE(@DOCS@("DILIST",INDEX,0),U,2))=$$LJ^XLFSTR($PIECE(@DOCS@("DILIST",INDEX,0),U,3),19," ")_ACCOUNT("TEXT")
End DoDot:1
+21 FOR ACCOUNT=1:-1:0
Begin DoDot:1
+22 if '$DATA(@DATA@(ACCOUNT))
QUIT
+23 IF ACCOUNT=0
Begin DoDot:2
+24 IF ($Y+CBUFFER+4)>IOSL!($Y=0)
Begin DoDot:3
+25 SET STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
End DoDot:3
if $GET(STOP)
QUIT
+26 WRITE !,$$CJ^XLFSTR("*** DISUSERED/TERMINATED USERS ***",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," "),!
+27 WRITE $$CJ^XLFSTR($$REPEAT^XLFSTR("-",34),$SELECT(+$GET(IOM)>0:IOM,1:80)," "),!
End DoDot:2
+28 SET NAME=""
FOR
SET NAME=$ORDER(@DATA@(ACCOUNT,NAME))
if NAME=""!($GET(STOP))
QUIT
Begin DoDot:2
+29 IF ($Y+CBUFFER)>IOSL!($Y=0)
Begin DoDot:3
+30 SET STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
End DoDot:3
if $GET(STOP)
QUIT
+31 WRITE $$LJ^XLFSTR(NAME,37," ")_@DATA@(ACCOUNT,NAME)
+32 IF ($Y+1)<IOSL
WRITE !
+33 SET OUTPUT=1
End DoDot:2
End DoDot:1
if $GET(STOP)
QUIT
+34 IF '$GET(STOP)
Begin DoDot:1
+35 IF '$GET(OUTPUT)
Begin DoDot:2
+36 SET STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
+37 if STOP
QUIT
+38 WRITE !,$$CJ^XLFSTR("0 PROVIDERS FOUND",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," "),!
End DoDot:2
if $GET(STOP)
QUIT
+39 IF ($Y+2)>IOSL
SET STOP=$$HEADER^ORUTL("PROVIDERS WITH A DETOX/MAINTENANCE ID",.PGNUM,.COL)
+40 if $GET(STOP)
QUIT
+41 WRITE !,$$CJ^XLFSTR("[END OF REPORT]",$SELECT(+$GET(IOM)>0:(IOM-1),1:79)," ")
End DoDot:1
+42 KILL @DOCS,@DATA
+43 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+44 QUIT
