Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSODEARW

PSODEARW.m

Go to the documentation of this file. 
  1. PSODEARW ;WILM/BDB - INTEGRITY CHECK ON DEA NUMBERS ;2/28/22  17:25
  1.  ;;7.0;OUTPATIENT PHARMACY;**545,731**;DEC 1997;Build 18
  1.  ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
  1.  ;External reference to sub-file NEW DEA #'S (#200.5321) is supported by DBIA 7000
  1.  Q
  1.  ;
  1. EN  ; Main Routine Entry Point
  1.  N DIROUT,DTOUT,DUOUT,PSOQ,PSOPAGE,POP,PSHEADER,PSCPRSSA,PSOEDS,PSOSCR,PSOOUT,PSOTYP,PSOQ
  1.  S PSOPAGE=0
  1.  S PSOQ=0          ; quit flag
  1.  ;
  1.  S PSHEADER="Integrity Check on DEA Numbers Report"
  1.  D  Q:$G(PSOTYP)="D"  I $G(PSOOUT) Q
  1.  . S PSOTYP=$$TYPE() I $G(PSOOUT) Q
  1.  . I $G(PSOTYP)="D" D DL^PSODEARX I $G(PSOOUT) Q
  1.  . I $G(PSOTYP)="D" D RUN^PSODEARX(PSHEADER)
  1.  ;
  1.  D DEVICE Q:PSOQ   ; Print to device
  1.  S PSCPRSSA="B" ;temp  BOTH
  1.  D RUN(PSHEADER) Q:PSOQ  ; Run Report
  1.  Q
  1.  ;
  1. DEVICE  ; Request Device Information
  1.  N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,RTN,VAR
  1.  K IO("Q")
  1.  S %ZIS="QM"
  1.  W ! D ^%ZIS
  1.  I POP S PSOQ=1 Q
  1.  S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
  1.  I $D(IO("Q")) D  S PSOQ=1
  1.  . S RTN=$P($T(+1)," ",1)
  1.  . S ZTRTN="RUN^"_RTN_"(PSHEADER)"
  1.  . S ZTIO=ION
  1.  . S ZTSAVE("PS*")=""
  1.  . S ZTDESC="DEA NUMBERS INTEGRITY CHECK"
  1.  . D ^%ZTLOAD
  1.  . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
  1.  . D HOME^%ZIS
  1.  U IO
  1.  Q
  1.  ;
  1. RUN(PSHEADER)  ; Run Report
  1.  N PSCOUNT2
  1.  K ^TMP($J,"PSODEARW") ; Clear the temporary accumulator
  1.  D COMPILE
  1.  U IO
  1.  D HDR(PSHEADER)
  1.  I '$D(^TMP($J,"PSODEARW")) W "There is no Data to Print",!
  1.  S PSCOUNT2=0 F  S PSCOUNT2=$O(^TMP($J,"PSODEARW",PSCOUNT2)) Q:+PSCOUNT2=0  Q:PSOQ  D
  1.  . W ^TMP($J,"PSODEARW",PSCOUNT2,1),! D CHKP(PSHEADER) Q:PSOQ
  1.  Q:PSOQ
  1.  I 'PSOSCR W !,@IOF
  1.  D ^%ZISC
  1.  K ^TMP($J,"PSODEARW") ; Clear the temporary accumulator
  1.  I PSOSCR K DIR("A") S DIR(0)="E" D ^DIR K DIR
  1.  Q
  1.  ;
  1. COMPILE  ; -- Compile the report lines into the sort global
  1.  N NAME,NPIEN,NPDEAIEN,ERROR,PRVNAME,NPDEA,DNDEA,PSOLINE,PSCOUNT1,NXNPIEN
  1.  N DNDETOX,NXDEA,DETOXCT,DNINPT,DNINPTCT,INDIV,DNDEAIEN,DNDEASX,DNDEATYP,NXDEAIEN
  1.  S ERROR(1)="MISSING DEA NUMBER IN (#8991.9)"
  1.  S ERROR(2)="PROVIDER NAME MISMATCH (#200)(#8991.9)"
  1.  S ERROR(3)="INSTITUTIONAL DEA MISSING SUFFIX"
  1.  S ERROR(4)="DEA ASSIGNED TO PROVIDER:"
  1.  S ERROR(5)="DUPLICATE DETOX NUMBER"
  1.  S ERROR(6)="PROVIDER WITH MULTIPLE DETOX NUMBERS"
  1.  S ERROR(7)="PROVIDER MISSING DEA INPATIENT FLAG"
  1.  S PSCOUNT1=0
  1.  S NAME="" F  S NAME=$O(^VA(200,"B",NAME)) Q:NAME=""  D
  1.  . S NPIEN=0 F  S NPIEN=$O(^VA(200,"B",NAME,NPIEN)) Q:'NPIEN  D
  1.  . . Q:'$D(^VA(200,NPIEN,"PS4"))
  1.  . . I '$O(^VA(200,NPIEN,"PS4",0)) Q
  1.  . . S PRVNAME=$$GET1^DIQ(200,NPIEN,.01,"E")
  1.  . . ;P731 detox/x-waiver removal
  1.  . . ;CHECK FOR PROVIDER WITH MULTIPLE DETOX NUMBERS ERROR 6
  1.  . . ;S DETOXCT=0,NPDEAIEN=0 F  S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN  D  I DETOXCT>1 Q
  1.  . . ;. S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
  1.  . . ;. S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
  1.  . . ;. S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03) I DNDETOX]"" S DETOXCT=DETOXCT+1
  1.  . . ;. I DETOXCT>1 D
  1.  . . ;. . S PSOLINE="",NPDEA=""
  1.  . . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,   
  1.  . . ;. . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(6),"38T")   ; ERROR TEXT
  1.  . . ;. . S PSCOUNT1=PSCOUNT1+1
  1.  . . ;. . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  . . ;CHECK FOR PROVIDER WITH ALL INDIVIDUAL DEA MISSING DEA INPATIENT FLAG ERROR 7
  1.  . . S INDIV=0,DNINPTCT=0,NPDEAIEN=0 F  S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN  D  I DNINPTCT>0 Q
  1.  . . . S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
  1.  . . . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I") Q:DNDEAIEN=""
  1.  . . . S DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"E") I DNDEATYP="INDIVIDUAL" S INDIV=1 D
  1.  . . . . S DNINPT=$$GET1^DIQ(8991.9,DNDEAIEN,.06) I DNINPT="YES" S DNINPTCT=DNINPTCT+1
  1.  . . I INDIV>0,DNINPTCT=0 D
  1.  . . . S PSOLINE="",NPDEA=""
  1.  . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,   
  1.  . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(7),"38T")   ; ERROR TEXT
  1.  . . . S PSCOUNT1=PSCOUNT1+1
  1.  . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  . . ;CHECK EACH PROVIDER DEA
  1.  . . S NPDEAIEN=0 F  S NPDEAIEN=$O(^VA(200,NPIEN,"PS4",NPDEAIEN)) Q:'NPDEAIEN  D  I DNDEA']"" Q
  1.  . . . ; CHECK FOR MISSING DEA NUMBER (FILE: #8991.9) ERROR 1
  1.  . . . S NPDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.01,"E")
  1.  . . . S DNDEA=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"E")
  1.  . . . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
  1.  . . . I (DNDEA']"")!(NPDEA'=DNDEA) D
  1.  . . . . S PSOLINE=""
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(1),"38T")                         ; ERROR TEXT
  1.  . . . . S PSCOUNT1=PSCOUNT1+1
  1.  . . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  . . . ;CHECK FOR PROVIDER NAME MISMATCH (#200)(#8991.9) ERROR 2
  1.  . . . I (DNDEA]"")&($P(PRVNAME,",",1)'=$P($$GET1^DIQ(8991.9,DNDEAIEN,1.1),",",1)) D
  1.  . . . . S PSOLINE=""
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,   
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(2),"38T")         ; ERROR TEXT
  1.  . . . . S PSCOUNT1=PSCOUNT1+1
  1.  . . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  . . . ;CHECK FOR INSTITUTIONAL DEA MISSING SUFFIX ERROR 3
  1.  . . . S DNDEAIEN=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.03,"I")
  1.  . . . S DNDEATYP=$$GET1^DIQ(8991.9,DNDEAIEN,.07,"E")
  1.  . . . S DNDEASX=$$GET1^DIQ(200.5321,NPDEAIEN_","_NPIEN_",",.02,"E")
  1.  . . . I (DNDEATYP="INSTITUTIONAL")&(DNDEASX="") D  Q
  1.  . . . . S PSOLINE=""
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,   
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(3),"38T")                         ; ERROR TEXT
  1.  . . . . S PSCOUNT1=PSCOUNT1+1
  1.  . . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  . . . ;CHECK FOR DEA ASSIGNED TO PROVIDER: ERROR 4
  1.  . . . I DNDEATYP="INDIVIDUAL" S NXNPIEN="" F  S NXNPIEN=$O(^VA(200,"PS4",NPDEA,NXNPIEN)) Q:NXNPIEN=""  I NXNPIEN'=NPIEN D  Q
  1.  . . . . S PSOLINE=""
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,   
  1.  . . . . S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(4)_"  "_$$GET1^DIQ(200,NXNPIEN_",",.01),"38T")   ; ERROR TEXT
  1.  . . . . S PSCOUNT1=PSCOUNT1+1
  1.  . . . . S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  . . . ;CHECK FOR DUPLICATE DETOX NUMBER
  1.  . . . ;P731 detox/x-waiver removal
  1.  . . . ;S DNDETOX=$$GET1^DIQ(8991.9,DNDEAIEN,.03)
  1.  . . . ;I DNDETOX]"" S NXDEA="" F  S NXDEA=$O(^XTV(8991.9,"D",DNDETOX,NXDEA)) Q:NXDEA=""  I NXDEA'=NPDEA D  Q
  1.  . . . ;. S NXDEAIEN=$O(^XTV(8991.9,"D",DNDETOX,NXDEA,""))
  1.  . . . ;. S PSOLINE=""
  1.  . . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(PRVNAME,"18T")_"  "                     ; NAME            #200,    #.01
  1.  . . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPIEN,"9T")_"  "                        ; IEN             #200
  1.  . . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(NPDEA,"9T")_"  "                        ; NEW DEA NUMBER  #200,   
  1.  . . . ;. S PSOLINE=PSOLINE_$$LJ^XLFSTR(ERROR(5)_"  DEA:"_$$GET1^DIQ(8991.9,NXDEAIEN_",",.01),"38T")   ; ERROR TEXT
  1.  . . . ;. S PSCOUNT1=PSCOUNT1+1
  1.  . . . ;. S ^TMP($J,"PSODEARW",PSCOUNT1,1)=PSOLINE
  1.  Q
  1.  ;
  1. HDR(PSHEADER)  ; Report header
  1.  N PSOI
  1.  S PSOPAGE=PSOPAGE+1
  1.  W @IOF,PSHEADER,?(IOM-31),"Run Date: ",$$FMTE^XLFDT(DT,"5DZ")," Page: ",PSOPAGE
  1.  W !,$$TITLES
  1.  W ! F PSOI=1:1:$S($G(IOM):(IOM-1),1:130) W "-"
  1.  W !
  1.  Q
  1.  ;
  1. CHKP(PSHEADER)  ; Check for End Of Page
  1.  I $Y>(IOSL-4) D:PSOSCR  Q:PSOQ  D HDR(PSHEADER)
  1.  . N X,Y,DTOUT,DUOUT,DIRUT,DIR
  1.  . U IO(0) S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT) PSOQ=2
  1.  . U IO
  1.  Q
  1.  ;
  1. TITLES()  ; -- Create the header TITLES.
  1.  N TITLES
  1.  S TITLES=""
  1.  S TITLES=TITLES_$$LJ^XLFSTR("NAME","18T")_"  "             ; NAME                    #200,    #.01                 
  1.  S TITLES=TITLES_$$LJ^XLFSTR("IEN","9T")_"  "               ; IEN                     #200
  1.  S TITLES=TITLES_$$LJ^XLFSTR("DEA(#200)","9T")_"  "        ; NEW DEA NUMBER          #200,    #
  1.  S TITLES=TITLES_$$LJ^XLFSTR("ERROR TEXT","38T")       ; ERROR TEXT
  1.  Q TITLES
  1.  ;
  1. TYPE() ;Prompt for report format or delimited list
  1.  N PSOTYP
  1.  S PSOTYP=""
  1.  W ! K DIR,Y S DIR(0)="S^R:Report;D:Delimited File"
  1.  S DIR("?",1)="Enter 'R' to see the output in a report format,"
  1.  S DIR("?")="enter 'D' for a delimited list that can be exported to Excel."
  1.  S DIR("A")="Select (R)eport or (D)elimited File"
  1.  S DIR("B")="R"
  1.  D ^DIR K DIR I $D(DIRUT) S PSOOUT=1 K DIRUT,DTOUT,DUOUT,DIR,X,Y Q PSOTYP
  1.  S PSOTYP=Y
  1.  K DIRUT,DTOUT,DUOUT,DIR,X,Y
  1.  Q PSOTYP
  1.  ;