PSODEARW ;WILM/BDB - INTEGRITY CHECK ON DEA NUMBERS ;2/28/22 17:25
;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
Q
;
EN ; Main Routine Entry Point
N DIROUT,DTOUT,DUOUT,PSOQ,PSOPAGE,POP,PSHEADER,PSCPRSSA,PSOEDS,PSOSCR,PSOOUT,PSOTYP,PSOQ
S PSOPAGE=0
S PSOQ=0 ; quit flag
;
S PSHEADER="Integrity Check on DEA Numbers Report"
D Q:$G(PSOTYP)="D" I $G(PSOOUT) Q
. S PSOTYP=$$TYPE() I $G(PSOOUT) Q
. I $G(PSOTYP)="D" D DL^PSODEARX I $G(PSOOUT) Q
. I $G(PSOTYP)="D" D RUN^PSODEARX(PSHEADER)
;
D DEVICE Q:PSOQ ; Print to device
S PSCPRSSA="B" ;temp BOTH
D RUN(PSHEADER) Q:PSOQ ; Run Report
Q
;
DEVICE ; Request Device Information
N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,RTN,VAR
K IO("Q")
S %ZIS="QM"
W ! D ^%ZIS
I POP S PSOQ=1 Q
S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
I $D(IO("Q")) D S PSOQ=1
. S RTN=$P($T(+1)," ",1)
. S ZTRTN="RUN^"_RTN_"(PSHEADER)"
. S ZTIO=ION
. S ZTSAVE("PS*")=""
. S ZTDESC="DEA NUMBERS INTEGRITY CHECK"
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
Q
;
RUN(PSHEADER) ; Run Report
N PSCOUNT2
K ^TMP($J,"PSODEARW") ; Clear the temporary accumulator
D COMPILE
U IO
D HDR(PSHEADER)
I '$D(^TMP($J,"PSODEARW")) W "There is no Data to Print",!
S PSCOUNT2=0 F S PSCOUNT2=$O(^TMP($J,"PSODEARW",PSCOUNT2)) Q:+PSCOUNT2=0 Q:PSOQ D
. W ^TMP($J,"PSODEARW",PSCOUNT2,1),! D CHKP(PSHEADER) Q:PSOQ
Q:PSOQ
I 'PSOSCR W !,@IOF
D ^%ZISC
K ^TMP($J,"PSODEARW") ; Clear the temporary accumulator
I PSOSCR K DIR("A") S DIR(0)="E" D ^DIR K DIR
Q
;
COMPILE ; -- Compile the report lines into the sort global
N NAME,NPIEN,NPDEAIEN,ERROR,PRVNAME,NPDEA,DNDEA,PSOLINE,PSCOUNT1,NXNPIEN
N DNDETOX,NXDEA,DETOXCT,DNINPT,DNINPTCT,INDIV,DNDEAIEN,DNDEASX,DNDEATYP,NXDEAIEN
S ERROR(1)="MISSING DEA NUMBER IN (#8991.9)"
S ERROR(2)="PROVIDER NAME MISMATCH (#200)(#8991.9)"
S ERROR(3)="INSTITUTIONAL DEA MISSING SUFFIX"
S ERROR(4)="DEA ASSIGNED TO PROVIDER:"
S ERROR(5)="DUPLICATE DETOX NUMBER"
S ERROR(6)="PROVIDER WITH MULTIPLE DETOX NUMBERS"
S ERROR(7)="PROVIDER MISSING DEA INPATIENT FLAG"
S PSCOUNT1=0
S NAME="" F S NAME=$O(^VA(200,"B",NAME)) Q:NAME="" D
. S NPIEN=0 F S NPIEN=$O(^VA(200,"B",NAME,NPIEN)) Q:'NPIEN D
. . Q:'$D(^VA(200,NPIEN,"PS4"))
. . I '$O(^VA(200,NPIEN,"PS4",0)) Q
. . S PRVNAME=$$GET1^DIQ(200,NPIEN,.01,"E")
. . ;P731 detox/x-waiver removal
. . ;CHECK FOR PROVIDER WITH MULTIPLE DETOX NUMBERS ERROR 6
. . ;S DETOXCT=0,NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D I DETOXCT>1 Q
. . ;. S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
. . ;. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. . ;. S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03) I DNDETOX]"" S DETOXCT=DETOXCT+1
. . ;. I DETOXCT>1 D
. . ;. . S PSOLINE="",NPDEA=""
. . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(6),"38T") ; ERROR TEXT
. . ;. . S PSCOUNT1=PSCOUNT1+1
. . ;. . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
. . ;CHECK FOR PROVIDER WITH ALL INDIVIDUAL DEA MISSING DEA INPATIENT FLAG ERROR 7
. . S INDIV=0,DNINPTCT=0,NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D I DNINPTCT>0 Q
. . . S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
. . . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I") Q:DNDEAIEN=""
. . . S DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"E") I DNDEATYP="INDIVIDUAL" S INDIV=1 D
. . . . S DNINPT=$$GET1^DIQ(8991.9,DNDEAIEN,.06) I DNINPT="YES" S DNINPTCT=DNINPTCT+1
. . I INDIV>0,DNINPTCT=0 D
. . . S PSOLINE="",NPDEA=""
. . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(7),"38T") ; ERROR TEXT
. . . S PSCOUNT1=PSCOUNT1+1
. . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
. . ;CHECK EACH PROVIDER DEA
. . S NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D I DNDEA']"" Q
. . . ; CHECK FOR MISSING DEA NUMBER (FILE: #8991.9) ERROR 1
. . . S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
. . . S DNDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"E")
. . . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. . . I (DNDEA']"")!(NPDEA'=DNDEA) D
. . . . S PSOLINE=""
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(1),"38T") ; ERROR TEXT
. . . . S PSCOUNT1=PSCOUNT1+1
. . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
. . . ;CHECK FOR PROVIDER NAME MISMATCH (#200)(#8991.9) ERROR 2
. . . I (DNDEA]"")&($P(PRVNAME,",",1)'=$P($$GET1^DIQ(8991.9,DNDEAIEN,1.1),",",1)) D
. . . . S PSOLINE=""
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(2),"38T") ; ERROR TEXT
. . . . S PSCOUNT1=PSCOUNT1+1
. . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
. . . ;CHECK FOR INSTITUTIONAL DEA MISSING SUFFIX ERROR 3
. . . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
. . . S DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")
. . . S DNDEASX=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02,"E")
. . . I (DNDEATYP="INSTITUTIONAL")&(DNDEASX="") D Q
. . . . S PSOLINE=""
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(3),"38T") ; ERROR TEXT
. . . . S PSCOUNT1=PSCOUNT1+1
. . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
. . . ;CHECK FOR DEA ASSIGNED TO PROVIDER: ERROR 4
. . . I DNDEATYP="INDIVIDUAL" S NXNPIEN="" F S NXNPIEN=$O(^VA(200,"PS4",NPDEA,NXNPIEN)) Q:NXNPIEN="" I NXNPIEN'=NPIEN D Q
. . . . S PSOLINE=""
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(4)_" "_$$GET1^DIQ(200,NXNPIEN_",",.01),"38T") ; ERROR TEXT
. . . . S PSCOUNT1=PSCOUNT1+1
. . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
. . . ;CHECK FOR DUPLICATE DETOX NUMBER
. . . ;P731 detox/x-waiver removal
. . . ;S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03)
. . . ;I DNDETOX]"" S NXDEA="" F S NXDEA=$O(^XTV(8991.9,"D",DNDETOX,NXDEA)) Q:NXDEA="" I NXDEA'=NPDEA D Q
. . . ;. S NXDEAIEN=$O(^XTV(8991.9,"D",DNDETOX,NXDEA,""))
. . . ;. S PSOLINE=""
. . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
. . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
. . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
. . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(5)_" DEA:"_$$GET1^DIQ(8991.9,NXDEAIEN_",",.01),"38T") ; ERROR TEXT
. . . ;. S PSCOUNT1=PSCOUNT1+1
. . . ;. S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
Q
;
HDR(PSHEADER) ; Report header
N PSOI
S PSOPAGE=PSOPAGE+1
W @IOF,PSHEADER,?(IOM-31),"Run Date: ",$$FMTE^XLFDT(DT,"5DZ")," Page: ",PSOPAGE
W !,$$TITLES
W ! F PSOI=1:1:$S($G(IOM):(IOM-1),1:130) W "-"
W !
Q
;
CHKP(PSHEADER) ; Check for End Of Page
I $Y>(IOSL-4) D:PSOSCR Q:PSOQ D HDR(PSHEADER)
. N X,Y,DTOUT,DUOUT,DIRUT,DIR
. U IO(0) S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT) PSOQ=2
. U IO
Q
;
TITLES() ; -- Create the header TITLES.
N TITLES
S TITLES=""
S TITLES=TITLES_$$LJ^XLFSTR("NAME","18T")_" " ; NAME #200, #.01
S TITLES=TITLES_$$LJ^XLFSTR("IEN","9T")_" " ; IEN #200
S TITLES=TITLES_$$LJ^XLFSTR("DEA(#200)","9T")_" " ; NEW DEA NUMBER #200, #
S TITLES=TITLES_$$LJ^XLFSTR("ERROR TEXT","38T") ; ERROR TEXT
Q TITLES
;
TYPE() ;Prompt for report format or delimited list
N PSOTYP
S PSOTYP=""
W ! K DIR,Y S DIR(0)="S^R:Report;D:Delimited File"
S DIR("?",1)="Enter 'R' to see the output in a report format,"
S DIR("?")="enter 'D' for a delimited list that can be exported to Excel."
S DIR("A")="Select (R)eport or (D)elimited File"
S DIR("B")="R"
D ^DIR K DIR I $D(DIRUT) S PSOOUT=1 K DIRUT,DTOUT,DUOUT,DIR,X,Y Q PSOTYP
S PSOTYP=Y
K DIRUT,DTOUT,DUOUT,DIR,X,Y
Q PSOTYP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEARW 10000 printed Apr 09, 2024@21:37:25 Page 2
PSODEARW ;WILM/BDB - INTEGRITY CHECK ON DEA NUMBERS ;2/28/22 17:25
+1 ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
+2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
+3 ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
+4 QUIT
+5 ;
EN ; Main Routine Entry Point
+1 NEW DIROUT,DTOUT,DUOUT,PSOQ,PSOPAGE,POP,PSHEADER,PSCPRSSA,PSOEDS,PSOSCR,PSOOUT,PSOTYP,PSOQ
+2 SET PSOPAGE=0
+3 ; quit flag
SET PSOQ=0
+4 ;
+5 SET PSHEADER="Integrity Check on DEA Numbers Report"
+6 Begin DoDot:1
+7 SET PSOTYP=$$TYPE()
IF $GET(PSOOUT)
QUIT
+8 IF $GET(PSOTYP)="D"
DO DL^PSODEARX
IF $GET(PSOOUT)
QUIT
+9 IF $GET(PSOTYP)="D"
DO RUN^PSODEARX(PSHEADER)
End DoDot:1
if $GET(PSOTYP)="D"
QUIT
IF $GET(PSOOUT)
QUIT
+10 ;
+11 ; Print to device
DO DEVICE
if PSOQ
QUIT
+12 ;temp BOTH
SET PSCPRSSA="B"
+13 ; Run Report
DO RUN(PSHEADER)
if PSOQ
QUIT
+14 QUIT
+15 ;
DEVICE ; Request Device Information
+1 NEW %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,RTN,VAR
+2 KILL IO("Q")
+3 SET %ZIS="QM"
+4 WRITE !
DO ^%ZIS
+5 IF POP
SET PSOQ=1
QUIT
+6 SET PSOSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET RTN=$PIECE($TEXT(+1)," ",1)
+9 SET ZTRTN="RUN^"_RTN_"(PSHEADER)"
+10 SET ZTIO=ION
+11 SET ZTSAVE("PS*")=""
+12 SET ZTDESC="DEA NUMBERS INTEGRITY CHECK"
+13 DO ^%ZTLOAD
+14 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+15 DO HOME^%ZIS
End DoDot:1
SET PSOQ=1
+16 USE IO
+17 QUIT
+18 ;
RUN(PSHEADER) ; Run Report
+1 NEW PSCOUNT2
+2 ; Clear the temporary accumulator
KILL ^TMP($JOB,"PSODEARW")
+3 DO COMPILE
+4 USE IO
+5 DO HDR(PSHEADER)
+6 IF '$DATA(^TMP($JOB,"PSODEARW"))
WRITE "There is no Data to Print",!
+7 SET PSCOUNT2=0
FOR
SET PSCOUNT2=$ORDER(^TMP($JOB,"PSODEARW",PSCOUNT2))
if +PSCOUNT2=0
QUIT
if PSOQ
QUIT
Begin DoDot:1
+8 WRITE ^TMP($JOB,"PSODEARW",PSCOUNT2,1),!
DO CHKP(PSHEADER)
if PSOQ
QUIT
End DoDot:1
+9 if PSOQ
QUIT
+10 IF 'PSOSCR
WRITE !,@IOF
+11 DO ^%ZISC
+12 ; Clear the temporary accumulator
KILL ^TMP($JOB,"PSODEARW")
+13 IF PSOSCR
KILL DIR("A")
SET DIR(0)="E"
DO ^DIR
KILL DIR
+14 QUIT
+15 ;
COMPILE ; -- Compile the report lines into the sort global
+1 NEW NAME,NPIEN,NPDEAIEN,ERROR,PRVNAME,NPDEA,DNDEA,PSOLINE,PSCOUNT1,NXNPIEN
+2 NEW DNDETOX,NXDEA,DETOXCT,DNINPT,DNINPTCT,INDIV,DNDEAIEN,DNDEASX,DNDEATYP,NXDEAIEN
+3 SET ERROR(1)="MISSING DEA NUMBER IN (#8991.9)"
+4 SET ERROR(2)="PROVIDER NAME MISMATCH (#200)(#8991.9)"
+5 SET ERROR(3)="INSTITUTIONAL DEA MISSING SUFFIX"
+6 SET ERROR(4)="DEA ASSIGNED TO PROVIDER:"
+7 SET ERROR(5)="DUPLICATE DETOX NUMBER"
+8 SET ERROR(6)="PROVIDER WITH MULTIPLE DETOX NUMBERS"
+9 SET ERROR(7)="PROVIDER MISSING DEA INPATIENT FLAG"
+10 SET PSCOUNT1=0
+11 SET NAME=""
FOR
SET NAME=$ORDER(^VA(200,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+12 SET NPIEN=0
FOR
SET NPIEN=$ORDER(^VA(200,"B",NAME,NPIEN))
if 'NPIEN
QUIT
Begin DoDot:2
+13 if '$DATA(^VA(200,NPIEN,"PS4"))
QUIT
+14 IF '$ORDER(^VA(200,NPIEN,"PS4",0))
QUIT
+15 SET PRVNAME=$$GET1^DIQ(200,NPIEN,.01,"E")
+16 ;P731 detox/x-waiver removal
+17 ;CHECK FOR PROVIDER WITH MULTIPLE DETOX NUMBERS ERROR 6
+18 ;S DETOXCT=0,NPDEAIEN=0 F S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN D I DETOXCT>1 Q
+19 ;. S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
+20 ;. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+21 ;. S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03) I DNDETOX]"" S DETOXCT=DETOXCT+1
+22 ;. I DETOXCT>1 D
+23 ;. . S PSOLINE="",NPDEA=""
+24 ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
+25 ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
+26 ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
+27 ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(6),"38T") ; ERROR TEXT
+28 ;. . S PSCOUNT1=PSCOUNT1+1
+29 ;. . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
+30 ;CHECK FOR PROVIDER WITH ALL INDIVIDUAL DEA MISSING DEA INPATIENT FLAG ERROR 7
+31 SET INDIV=0
SET DNINPTCT=0
SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:3
+32 SET NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
+33 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
if DNDEAIEN=""
QUIT
+34 SET DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")
IF DNDEATYP="INDIVIDUAL"
SET INDIV=1
Begin DoDot:4
+35 SET DNINPT=$$GET1^DIQ(8991.9,DNDEAIEN,.06)
IF DNINPT="YES"
SET DNINPTCT=DNINPTCT+1
End DoDot:4
End DoDot:3
IF DNINPTCT>0
QUIT
+36 IF INDIV>0
IF DNINPTCT=0
Begin DoDot:3
+37 SET PSOLINE=""
SET NPDEA=""
+38 ; NAME #200, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" "
+39 ; IEN #200
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" "
+40 ; NEW DEA NUMBER #200,
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" "
+41 ; ERROR TEXT
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(7),"38T")
+42 SET PSCOUNT1=PSCOUNT1+1
+43 SET ^TMP($JOB,"PSODEARW",PSCOUNT1,1)=PSOLINE
End DoDot:3
+44 ;CHECK EACH PROVIDER DEA
+45 SET NPDEAIEN=0
FOR
SET NPDEAIEN=$ORDER(^VA(200,NPIEN,"PS4",NPDEAIEN))
if 'NPDEAIEN
QUIT
Begin DoDot:3
+46 ; CHECK FOR MISSING DEA NUMBER (FILE: #8991.9) ERROR 1
+47 SET NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
+48 SET DNDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"E")
+49 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+50 IF (DNDEA']"")!(NPDEA'=DNDEA)
Begin DoDot:4
+51 SET PSOLINE=""
+52 ; NAME #200, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" "
+53 ; IEN #200
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" "
+54 ; NEW DEA NUMBER #200,
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" "
+55 ; ERROR TEXT
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(1),"38T")
+56 SET PSCOUNT1=PSCOUNT1+1
+57 SET ^TMP($JOB,"PSODEARW",PSCOUNT1,1)=PSOLINE
End DoDot:4
+58 ;CHECK FOR PROVIDER NAME MISMATCH (#200)(#8991.9) ERROR 2
+59 IF (DNDEA]"")&($PIECE(PRVNAME,",",1)'=$PIECE($$GET1^DIQ(8991.9,DNDEAIEN,1.1),",",1))
Begin DoDot:4
+60 SET PSOLINE=""
+61 ; NAME #200, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" "
+62 ; IEN #200
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" "
+63 ; NEW DEA NUMBER #200,
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" "
+64 ; ERROR TEXT
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(2),"38T")
+65 SET PSCOUNT1=PSCOUNT1+1
+66 SET ^TMP($JOB,"PSODEARW",PSCOUNT1,1)=PSOLINE
End DoDot:4
+67 ;CHECK FOR INSTITUTIONAL DEA MISSING SUFFIX ERROR 3
+68 SET DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
+69 SET DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")
+70 SET DNDEASX=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02,"E")
+71 IF (DNDEATYP="INSTITUTIONAL")&(DNDEASX="")
Begin DoDot:4
+72 SET PSOLINE=""
+73 ; NAME #200, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" "
+74 ; IEN #200
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" "
+75 ; NEW DEA NUMBER #200,
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" "
+76 ; ERROR TEXT
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(3),"38T")
+77 SET PSCOUNT1=PSCOUNT1+1
+78 SET ^TMP($JOB,"PSODEARW",PSCOUNT1,1)=PSOLINE
End DoDot:4
QUIT
+79 ;CHECK FOR DEA ASSIGNED TO PROVIDER: ERROR 4
+80 IF DNDEATYP="INDIVIDUAL"
SET NXNPIEN=""
FOR
SET NXNPIEN=$ORDER(^VA(200,"PS4",NPDEA,NXNPIEN))
if NXNPIEN=""
QUIT
IF NXNPIEN'=NPIEN
Begin DoDot:4
+81 SET PSOLINE=""
+82 ; NAME #200, #.01
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" "
+83 ; IEN #200
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" "
+84 ; NEW DEA NUMBER #200,
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" "
+85 ; ERROR TEXT
SET PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(4)_" "_$$GET1^DIQ(200,NXNPIEN_",",.01),"38T")
+86 SET PSCOUNT1=PSCOUNT1+1
+87 SET ^TMP($JOB,"PSODEARW",PSCOUNT1,1)=PSOLINE
End DoDot:4
QUIT
+88 ;CHECK FOR DUPLICATE DETOX NUMBER
+89 ;P731 detox/x-waiver removal
+90 ;S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03)
+91 ;I DNDETOX]"" S NXDEA="" F S NXDEA=$O(^XTV(8991.9,"D",DNDETOX,NXDEA)) Q:NXDEA="" I NXDEA'=NPDEA D Q
+92 ;. S NXDEAIEN=$O(^XTV(8991.9,"D",DNDETOX,NXDEA,""))
+93 ;. S PSOLINE=""
+94 ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_" " ; NAME #200, #.01
+95 ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_" " ; IEN #200
+96 ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_" " ; NEW DEA NUMBER #200,
+97 ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(5)_" DEA:"_$$GET1^DIQ(8991.9,NXDEAIEN_",",.01),"38T") ; ERROR TEXT
+98 ;. S PSCOUNT1=PSCOUNT1+1
+99 ;. S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
End DoDot:3
IF DNDEA']""
QUIT
End DoDot:2
End DoDot:1
+100 QUIT
+101 ;
HDR(PSHEADER) ; Report header
+1 NEW PSOI
+2 SET PSOPAGE=PSOPAGE+1
+3 WRITE @IOF,PSHEADER,?(IOM-31),"Run Date: ",$$FMTE^XLFDT(DT,"5DZ")," Page: ",PSOPAGE
+4 WRITE !,$$TITLES
+5 WRITE !
FOR PSOI=1:1:$SELECT($GET(IOM):(IOM-1),1:130)
WRITE "-"
+6 WRITE !
+7 QUIT
+8 ;
CHKP(PSHEADER) ; Check for End Of Page
+1 IF $Y>(IOSL-4)
if PSOSCR
Begin DoDot:1
+2 NEW X,Y,DTOUT,DUOUT,DIRUT,DIR
+3 USE IO(0)
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSOQ=2
+4 USE IO
End DoDot:1
if PSOQ
QUIT
DO HDR(PSHEADER)
+5 QUIT
+6 ;
TITLES() ; -- Create the header TITLES.
+1 NEW TITLES
+2 SET TITLES=""
+3 ; NAME #200, #.01
SET TITLES=TITLES_$$LJ^XLFSTR("NAME","18T")_" "
+4 ; IEN #200
SET TITLES=TITLES_$$LJ^XLFSTR("IEN","9T")_" "
+5 ; NEW DEA NUMBER #200, #
SET TITLES=TITLES_$$LJ^XLFSTR("DEA(#200)","9T")_" "
+6 ; ERROR TEXT
SET TITLES=TITLES_$$LJ^XLFSTR("ERROR TEXT","38T")
+7 QUIT TITLES
+8 ;
TYPE() ;Prompt for report format or delimited list
+1 NEW PSOTYP
+2 SET PSOTYP=""
+3 WRITE !
KILL DIR,Y
SET DIR(0)="S^R:Report;D:Delimited File"
+4 SET DIR("?",1)="Enter 'R' to see the output in a report format,"
+5 SET DIR("?")="enter 'D' for a delimited list that can be exported to Excel."
+6 SET DIR("A")="Select (R)eport or (D)elimited File"
+7 SET DIR("B")="R"
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSOOUT=1
KILL DIRUT,DTOUT,DUOUT,DIR,X,Y
QUIT PSOTYP
+9 SET PSOTYP=Y
+10 KILL DIRUT,DTOUT,DUOUT,DIR,X,Y
+11 QUIT PSOTYP
+12 ;
