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

ABSPOS31.m

Go to the documentation of this file. 
  1. ABSPOS31 ; IHS/FCS/DRS - survey prescribers' ID #s ; 
  1.  ;;1.0;PHARMACY POINT OF SALE;**15,20**;JUN 21, 2001;Build 38
  1.  ;
  1.  ;IHS/SD/RLT - 1/12/06 - Fix header - Patch 15
  1.  ;
  1.  ;IHS/SD/RLT - 3/26/07 - Patch 20
  1.  ;             Add NPI
  1.  ;
  1.  Q
  1.  ; Need to fix up ABSPOS31,32, etc. for screen output
  1.  ; $$TOSCREEN^ABSPOSU5 is available now.
  1. MAIN ;EP - option ABSP PROVIDER #S SURVEY
  1.  W !!,"Survey prescribers from recent prescriptions and see if we have",!
  1.  W "DEA #s, Medicaid #s, etc. on file for them.",!
  1.  N X1,X2,X,%H S X1=DT,X2=-60 D C^%DTC ; X = result
  1.  N START,END
  1.  S START=$$DATE^ABSPOSU1("Start date: ",X,1,2970000,4000000,"E",300)
  1.  Q:'START  S END=DT
  1.  N POP D ^%ZIS Q:$G(POP)
  1.  U $P W !,"...thinking...",!
  1.  I START D MAIN1(START)
  1.  D ^%ZISC
  1.  Q
  1. HEADING ;
  1.  W @IOF
  1.  W "Survey of Prescribers (",$T(+0),")   ",RPTDATE,!
  1.  W "For " N Y S Y=START X ^DD("DD") W Y
  1.  I START'=END S Y=END X ^DD("DD") W "-",Y,!
  1.  ;RLT - 1/12/06 - Fix header - Patch 15
  1.  ;W ?0,"Count",?8,"Name",?30,"DEA #",?42,"CAID",?54,"UPIN",?66,"CARE",!
  1.  ;W ?0,"Count",?8,"Name",?30,"DEA #",?42,"CAID",?54,"CARE",?66,"UPIN",!
  1.  ;RLT - 3/26/07 - Patch 20
  1.  W ?0,"Count",?8,"Name",?30,"NPI #",?42,"DEA#",?54,"CAID",?66,"CARE",!
  1.  Q
  1. MAIN1(START)       ; START = fileman date.time to start search
  1.  N RPTDATE S RPTDATE=$$NOWEXT^ABSPOSU1
  1.  DO SURVEY(START)
  1.  I '$D(^TMP("ABSPOS31",$J)) W !,"No prescriptions found?!",! Q
  1.  U IO D HEADING
  1.  N COUNT,DOC,NUMBERS,X
  1.  S COUNT="" F  S COUNT=$O(^TMP("ABSPOS31",$J,"B",COUNT),-1) Q:'COUNT  D
  1.  . S DOC=0 F  S DOC=$O(^TMP("ABSPOS31",$J,"B",COUNT,DOC)) Q:'DOC  D
  1.  . . S X=^TMP("ABSPOS31",$J,DOC)
  1.  . . W $J(COUNT,4),?5,$E($P(X,U,2),1,24) ;_"(`"_DOC_")",1,24)
  1.  . . N I F I=3:1:6 W ?I-3*12+30,$P(X,U,I)
  1.  . . W !
  1.  . . I $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$T(+0)) S DOC=99999999,COUNT=1
  1.  I +$H=58399 D ZWRITE^ABSPOS("IOST","ZTQUEUED","IOT","IO")
  1.  D ENDRPT^ABSPOSU5()
  1.  Q
  1. SURVEY(START)      ; START = fileman date.time
  1.  ; Build ^TMP($T(+0),$J,physician)=count^name^dea^caid^care^upin
  1.  ;       ^TMP($T(+0),$J,"B",count,physician)=""
  1.  N RXI,RXR,DOC,TIME,NAME
  1.  S TIME=START K ^TMP("ABSPOS31",$J)
  1.  F  D  S TIME=$O(^PSRX("AL",TIME)) Q:'TIME
  1.  . S RXI="" F  S RXI=$O(^PSRX("AL",TIME,RXI)) Q:'RXI  D
  1.  . . S RXR="" F  S RXR=$O(^PSRX("AL",TIME,RXI,RXR)) Q:RXR=""  D
  1.  . . . I RXR S DOC=$P($G(^PSRX(RXI,1,RXR,0)),U,17)
  1.  . . . E  S DOC=$P($G(^PSRX(RXI,0)),U,4)
  1.  . . . I DOC S NAME=$P($G(^VA(200,DOC,0)),U) S:NAME="" NAME="???"
  1.  . . . E  S DOC=0,NAME="(missing prescriber)"
  1.  . . . I $D(^TMP("ABSPOS31",$J,DOC)) S X=^(DOC)
  1.  . . . E  D
  1.  . . . . N NPI,DEA,CAID,UPIN,CARE
  1.  . . . . S NPI=$P($$NPI^XUSNPI("Individual_ID",DOC),U)    ;RLT - 3/26/07 - Patch 20
  1.  . . . . S:NPI'>0 NPI=""
  1.  . . . . S DEA=$P($G(^VA(200,DOC,"PS")),U,2)
  1.  . . . . S CAID=$P($G(^VA(200,DOC,9999999)),U,7)
  1.  . . . . S CARE=$P($G(^VA(200,DOC,9999999)),U,6)
  1.  . . . . S UPIN=$P($G(^VA(200,DOC,9999999)),U,8)
  1.  . . . . ;S X=U_NAME_U_DEA_U_CAID_U_CARE_U_UPIN
  1.  . . . . S X=U_NAME_U_NPI_U_DEA_U_CAID_U_CARE             ;RLT - 3/26/07 - Patch 20
  1.  . . . S $P(X,U)=$P(X,U)+1
  1.  . . . S ^TMP("ABSPOS31",$J,DOC)=X
  1.  ; Now index it by count
  1.  S DOC=""
  1.  F  S DOC=$O(^TMP("ABSPOS31",$J,DOC)) Q:"B"[DOC  D
  1.  . N X S X=^TMP("ABSPOS31",$J,DOC) N COUNT S COUNT=$P(X,U)
  1.  . S ^TMP("ABSPOS31",$J,"B",COUNT,DOC)=""
  1.  Q