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