XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08 17:17
;;8.0;KERNEL;**438,452,453,481,548**; Jul 10, 1995;Build 24
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Direct access to ^IBE(350.9, fields .02, 1.05, 19;.02, 19;1.01, 19;1.02, 19;1.03, 19;,1.04, 19;1.05 authorized by
; Integration Agreement #4964.
;
;
; NPI Extract Report
;
; Input parameter: N/A
;
; Other relevant variables:
; XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP
; storage subscript)
; Storage Global:
; ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
; where:
; Piece 1 => Purge Date - 1 year in future
; Piece 2 => Create Date - Today
; Piece 3 => Description
; Piece 4 => Last Date Compiled
; Piece 5 => $H last run start time
; Piece 6 => $H last run completion time
;
; ^XTMP("XUSNPIX2",1) = STATION INFO
; ^XTMP("XUSNPIX2",2) = DATA
;
; NPI => Unique NPI of entry
; LDT => Last Date Run, VA Fileman Format
;
; Entry Point - ENT called from XUSNPIX1
;
Q
;
ENT(XUSPROD,XUSVER) ; ENTRY POINT
; Initialize variables
N XUSRTN
S XUSRTN="XUSNPIX2"
S DTTM2=$$HTE^XLFDT($H,"2")
; Check to see if report is in use
L +^XTMP(XUSRTN):5 I '$T G EXIT
; Process Institution File
D INIT(XUSRTN)
; Pull Station(Institution) data
D STAT(XUSRTN)
; Process Report
D PROC2(XUSRTN,XUSPROD,DTTM2)
;
; Standard EXIT point
EXIT ;
K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J)
; Log Run Completion Time
S $P(^XTMP(XUSRTN,0),U,6)=$H
L -^XTMP(XUSRTN)
K P,XUSPT,INST,DTTM2,XUSIZE,XUSHDR,XUSTAXID
Q
;
INIT(XUSRTN) ; check/init variables
N XUSDESC
;
; Reset Temporary Scratch Global
K ^TMP(XUSRTN)
S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete"
S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
;
I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU
;
; Create pharmacy institution ^TMP file
D GETPHARM
Q
;
STAT(XUSRTN) ; Pull station and Institution info
N SINFO,DIC4,IBSITE,XUSCITY,XUSSTATE,XUSZIP
S (XUSCITY,XUSSTATE,XUSZIP)=""
; Pull site info
S SINFO=$$SITE^VASITE
; Station Number
S SITE=$P(SINFO,U,3)
; Institution
S INST=$P(SINFO,U)
;
; Get Federal Tax Id
S XUSTAXID=""
S IBSITE=0
F S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="") D
. S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5)
;
; *** Start XU*8.0*548 - RBN ***
; Get header for extracted data NOT email
I INST D
. S DIC4=$G(^DIC(4,INST,4))
. S XUSCITY=$P(DIC4,U,3)
. S XUSSTATE=$P(DIC4,U,4)
. I XUSSTATE S XUSSTATE=$P($G(^DIC(5,XUSSTATE,0)),U,2)
. S XUSZIP=$P(DIC4,U,5)
S XUSHDR="Station: "_SITE_U_XUSCITY_U_XUSSTATE_U_XUSZIP_U_"TYPE 2"_U_XUSVER
;
Q
;
PROC2(XUSRTN,XUSPROD,DTTM2) ;Process all Institution records
N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM,XUSDIV
N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA,XUSEOL
N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA,COUNT,TOTREC,MSGCNT,MAXSIZE,XUSBFN,I
;
; Set to 300000 for live
S MAXSIZE=300000
;
; Set end of line character
S XUSEOL="~~"
;
; set counter
S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0
; Loop through INSTITUTION NPI records NPI xref
S XUSNPI=0
F S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI D
. S INIEN=$O(^DIC(4,"ANPI",XUSNPI,""))
. ;
. ; Get Station Number
. S XUSSTA=$P($G(^DIC(4,INIEN,99)),U)
. ; Parent of Association
. I (INIEN'=INST)&('$$POA(INIEN,INST)) Q
. ; Initialize columns
. F XUSI=1:1:24 S XUSIN(XUSI)=""
. ;
. S XUSIN(1)=XUSNPI
. S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0=""
. ;Organization Name
. S XUSIN(2)=$P($G(^DIC(4,INIEN,99)),U,2)
. S XUSIN(3)=2
. S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3)
. ;
. ; Pay to Provider Address
. S XUSDIV=""
. I $D(XUSTMP("P2P","DEFAULT")) S XUSDIV=XUSTMP("P2P","DEFAULT")
. I $D(XUSTMP("P2P",INIEN))=1 S XUSDIV=XUSTMP("P2P",INIEN)
. I XUSDIV="" F I=1:1:6 S $P(XUSDATA2,U,I)=""
. I XUSDIV'="" S XUSDATA2=$$P2PEXP^XUSNPIXU(XUSDIV)
. ;
. ; Servicing Provider Address
. S DIC1=$G(^DIC(4,INIEN,1))
. I DIC1'="" D
. . S XUSIN(10)=$P(DIC1,U)
. . S XUSIN(11)=$P(DIC1,U,2)
. . S XUSIN(12)=$P(DIC1,U,3)
. . S XUSIN(13)=$P($G(DIC0),U,2)
. . I XUSIN(13) S XUSIN(13)=$P($G(^DIC(5,XUSIN(13),0)),U,2)
. . S XUSIN(14)=$P(DIC1,U,4)
. S XUSDATA3=XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13)_U_XUSIN(14)
. ;
. ;Phone number (place holder)
. S XUSIN(15)=""
. ;
. ; Get Taxonomy and Specialty
. S XUSTXY=0
. F S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY D
. . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9)
. . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7)
. . I XUSSPC'="" D
. . . I XUSIN(16)="" S XUSIN(16)=XUSSPC Q
. . . S XUSIN(16)=XUSIN(16)_";"_XUSSPC
. . I XUSTAX'="" D
. . . I XUSIN(17)="" S XUSIN(17)=XUSTAX Q
. . . ;S XUSIN(17)=XUSIN(17)_";"_XUSTAX
. . . ;
. . . ; *** Start ^XU*8.0*548 - RBN ***
. . . ;
. . . S:(XUSIN(17)'[XUSTAX) XUSIN(17)=XUSIN(17)_";"_XUSTAX
. . . ;
. . . ; *** End ^XU*8.0*548 - RBN ***
. ;
. ; Federal Tax ID
. S XUSIN(18)=$G(XUSTAXID)
. ;
. ; Medicaid Part A/B
. S XUSIN(19)=670899
. S XUSIN(20)="VA"_$E(SITE+10000,2,5)
. ;
. S XUSDATA4=XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19)_U_XUSIN(20)
. ;
. ; DEA Number
. S XUSIN(21)=$P($G(^DIC(4,INIEN,"DEA")),U)
. ;
. ; get Facility Type and Name
. S XUSFCT=$P($G(^DIC(4,INIEN,3)),U)
. I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U)
. I $G(XUSFCN)="PHARM" D
. . I $D(^TMP("XUSNPIX",$J,INIEN)) D
. . . S XUPHM=^TMP("XUSNPIX",$J,INIEN)
. . . ; get NCPDP from ^TMP
. . . S XUSIN(22)=$P($G(XUPHM),U)
. . . ; get station number from^TMP
. . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2)
. ;
. ; VISN Station Number
. S XUSIN(23)=XUSSTA
. ;
. S XUSDATA5=XUSIN(21)_U_XUSIN(22)_U_XUSIN(23)
. ;
. ; Get BCBS Payer ID Array
. K XUSBXID
. D INSTID^XUSNPIXU(.XUSBXID)
. ;
. ; Update counter and save Entry
. ;
. S COUNT=COUNT+1,TOTREC=TOTREC+1
. S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL
. S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
. I $D(XUSBXID) D
. . S XUSB=""
. . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D
. . . S COUNT=COUNT+1,TOTREC=TOTREC+1
. . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL
. . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
. K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID
. I XUSIZE>MAXSIZE D
. . D EOF(XUSRTN)
. . D EMAIL(XUSRTN) ;sending extracted data via MailMan
. . K ^TMP(XUSRTN,$J)
. . S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2)
. . S ^TMP(XUSRTN,$J,1)=XUSHDR
. . S COUNT=1,XUSIZE=0
;
D EOF(XUSRTN)
;
; Send the last message (if it has records)
I $G(COUNT)>1 D
.D EMAIL(XUSRTN) ;sending extracted data via MailMan
.K ^TMP(XUSRTN,$J)
.S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2)
;
; Set Summary totals
S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2
;
K XUSPT,LDTCMP,SITE,XUSTAXID
Q
;
EOF(XUSRTN) ;
Q:COUNT=1
S MSGCNT=MSGCNT+1
S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL
S COUNT=COUNT+1
S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
Q
;
; Email the message
EMAIL(XUSRTN) ;
N XMY
; Send email to designated recipients for live release
D MAILTO^XUSNPIX1(.XMY) ;p548
D ESEND
Q
;
ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM
;
S XMTEXT="^TMP("""_XUSRTN_""","_$J_","
S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2"
D ^XMD
Q
POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain
N XUSPOA
I +$G(INST)=0 Q 0 ; No institution - return false
POA1 ;
I $G(IEN)="" Q 0 ; No IEN remaining to check - return false
I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false
S XUSPOA(IEN)=""
S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution
I XUSPOA=INST Q 1 ; Found matching institution - return true
I IEN=XUSPOA Q 0 ; Top level reached - return false
S IEN=XUSPOA ; Reset IEN to check next level
G POA1
;
GETPHARM ;
; this subroutine retrieves data from the OUTPATIENT SITE file
; using the supported Pharmacy API PSS^PSO59.
; It takes the results and places them into a temporary
; global array that is accessed when processing data
; associated with a pharmacy institution.
N D,DIC,XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP
;
;Fix for Remedy Ticket 217164
;Quit if Outpatient Site API routine is not loaded
S X="PSO59" X ^%ZOSF("TEST") Q:'$T
;
K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes
D PSS^PSO59(,"??","XUS59") ;IA#4827
S XUS59DA=0
; gather data from each Outpatient site entry stored in the pharmacy
; ^TMP global and build 2nd ^TMP global for later processing
F S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA D
. ;
. ;Get Pharmacy NPI institution from API
. S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U)
. Q:XUSNPIDA']"" ; NPI institution does not exist
. ;
. ; Get Pharmacy Related Institution from API
. S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U)
. ; get station number off the related institution
. S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U)
. ;
. ; Get NCPDP number
. S XUNCP="" ;prevent previous values being carried over
. S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC
. I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02)
. S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U)
. ;
. ; rebuild the ^TMP global by NPI institution
. ; collect necessary data used in the 'PHARM' logic
. S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSNPIX2 9991 printed Dec 13, 2024@02:12:45 Page 2
XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08 17:17
+1 ;;8.0;KERNEL;**438,452,453,481,548**; Jul 10, 1995;Build 24
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Direct access to ^IBE(350.9, fields .02, 1.05, 19;.02, 19;1.01, 19;1.02, 19;1.03, 19;,1.04, 19;1.05 authorized by
+5 ; Integration Agreement #4964.
+6 ;
+7 ;
+8 ; NPI Extract Report
+9 ;
+10 ; Input parameter: N/A
+11 ;
+12 ; Other relevant variables:
+13 ; XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP
+14 ; storage subscript)
+15 ; Storage Global:
+16 ; ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6
+17 ; where:
+18 ; Piece 1 => Purge Date - 1 year in future
+19 ; Piece 2 => Create Date - Today
+20 ; Piece 3 => Description
+21 ; Piece 4 => Last Date Compiled
+22 ; Piece 5 => $H last run start time
+23 ; Piece 6 => $H last run completion time
+24 ;
+25 ; ^XTMP("XUSNPIX2",1) = STATION INFO
+26 ; ^XTMP("XUSNPIX2",2) = DATA
+27 ;
+28 ; NPI => Unique NPI of entry
+29 ; LDT => Last Date Run, VA Fileman Format
+30 ;
+31 ; Entry Point - ENT called from XUSNPIX1
+32 ;
+33 QUIT
+34 ;
ENT(XUSPROD,XUSVER) ; ENTRY POINT
+1 ; Initialize variables
+2 NEW XUSRTN
+3 SET XUSRTN="XUSNPIX2"
+4 SET DTTM2=$$HTE^XLFDT($HOROLOG,"2")
+5 ; Check to see if report is in use
+6 LOCK +^XTMP(XUSRTN):5
IF '$TEST
GOTO EXIT
+7 ; Process Institution File
+8 DO INIT(XUSRTN)
+9 ; Pull Station(Institution) data
+10 DO STAT(XUSRTN)
+11 ; Process Report
+12 DO PROC2(XUSRTN,XUSPROD,DTTM2)
+13 ;
+14 ; Standard EXIT point
EXIT ;
+1 KILL ^TMP(XUSRTN,$JOB),^TMP($JOB,"XUS59"),^TMP("XUSNPIX",$JOB)
+2 ; Log Run Completion Time
+3 SET $PIECE(^XTMP(XUSRTN,0),U,6)=$HOROLOG
+4 LOCK -^XTMP(XUSRTN)
+5 KILL P,XUSPT,INST,DTTM2,XUSIZE,XUSHDR,XUSTAXID
+6 QUIT
+7 ;
INIT(XUSRTN) ; check/init variables
+1 NEW XUSDESC
+2 ;
+3 ; Reset Temporary Scratch Global
+4 KILL ^TMP(XUSRTN)
+5 SET XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete"
+6 SET ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$HOROLOG
+7 ;
+8 IF '$DATA(^TMP("XUSNPIXU",$JOB))
DO BCBSID^XUSNPIXU
+9 ;
+10 ; Create pharmacy institution ^TMP file
+11 DO GETPHARM
+12 QUIT
+13 ;
STAT(XUSRTN) ; Pull station and Institution info
+1 NEW SINFO,DIC4,IBSITE,XUSCITY,XUSSTATE,XUSZIP
+2 SET (XUSCITY,XUSSTATE,XUSZIP)=""
+3 ; Pull site info
+4 SET SINFO=$$SITE^VASITE
+5 ; Station Number
+6 SET SITE=$PIECE(SINFO,U,3)
+7 ; Institution
+8 SET INST=$PIECE(SINFO,U)
+9 ;
+10 ; Get Federal Tax Id
+11 SET XUSTAXID=""
+12 SET IBSITE=0
+13 FOR
SET IBSITE=$ORDER(^IBE(350.9,IBSITE))
if 'IBSITE!(XUSTAXID'="")
QUIT
Begin DoDot:1
+14 SET XUSTAXID=$PIECE($GET(^IBE(350.9,IBSITE,1)),U,5)
End DoDot:1
+15 ;
+16 ; *** Start XU*8.0*548 - RBN ***
+17 ; Get header for extracted data NOT email
+18 IF INST
Begin DoDot:1
+19 SET DIC4=$GET(^DIC(4,INST,4))
+20 SET XUSCITY=$PIECE(DIC4,U,3)
+21 SET XUSSTATE=$PIECE(DIC4,U,4)
+22 IF XUSSTATE
SET XUSSTATE=$PIECE($GET(^DIC(5,XUSSTATE,0)),U,2)
+23 SET XUSZIP=$PIECE(DIC4,U,5)
End DoDot:1
+24 SET XUSHDR="Station: "_SITE_U_XUSCITY_U_XUSSTATE_U_XUSZIP_U_"TYPE 2"_U_XUSVER
+25 ;
+26 QUIT
+27 ;
PROC2(XUSRTN,XUSPROD,DTTM2) ;Process all Institution records
+1 NEW XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM,XUSDIV
+2 NEW XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA,XUSEOL
+3 NEW INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA,COUNT,TOTREC,MSGCNT,MAXSIZE,XUSBFN,I
+4 ;
+5 ; Set to 300000 for live
+6 SET MAXSIZE=300000
+7 ;
+8 ; Set end of line character
+9 SET XUSEOL="~~"
+10 ;
+11 ; set counter
+12 SET COUNT=1
SET (TOTREC,MSGCNT,XUSIZE)=0
+13 ; Loop through INSTITUTION NPI records NPI xref
+14 SET XUSNPI=0
+15 FOR
SET XUSNPI=$ORDER(^DIC(4,"ANPI",XUSNPI))
if 'XUSNPI
QUIT
Begin DoDot:1
+16 SET INIEN=$ORDER(^DIC(4,"ANPI",XUSNPI,""))
+17 ;
+18 ; Get Station Number
+19 SET XUSSTA=$PIECE($GET(^DIC(4,INIEN,99)),U)
+20 ; Parent of Association
+21 IF (INIEN'=INST)&('$$POA(INIEN,INST))
QUIT
+22 ; Initialize columns
+23 FOR XUSI=1:1:24
SET XUSIN(XUSI)=""
+24 ;
+25 SET XUSIN(1)=XUSNPI
+26 SET DIC0=$GET(^DIC(4,INIEN,0))
if DIC0=""
QUIT
+27 ;Organization Name
+28 SET XUSIN(2)=$PIECE($GET(^DIC(4,INIEN,99)),U,2)
+29 SET XUSIN(3)=2
+30 SET XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3)
+31 ;
+32 ; Pay to Provider Address
+33 SET XUSDIV=""
+34 IF $DATA(XUSTMP("P2P","DEFAULT"))
SET XUSDIV=XUSTMP("P2P","DEFAULT")
+35 IF $DATA(XUSTMP("P2P",INIEN))=1
SET XUSDIV=XUSTMP("P2P",INIEN)
+36 IF XUSDIV=""
FOR I=1:1:6
SET $PIECE(XUSDATA2,U,I)=""
+37 IF XUSDIV'=""
SET XUSDATA2=$$P2PEXP^XUSNPIXU(XUSDIV)
+38 ;
+39 ; Servicing Provider Address
+40 SET DIC1=$GET(^DIC(4,INIEN,1))
+41 IF DIC1'=""
Begin DoDot:2
+42 SET XUSIN(10)=$PIECE(DIC1,U)
+43 SET XUSIN(11)=$PIECE(DIC1,U,2)
+44 SET XUSIN(12)=$PIECE(DIC1,U,3)
+45 SET XUSIN(13)=$PIECE($GET(DIC0),U,2)
+46 IF XUSIN(13)
SET XUSIN(13)=$PIECE($GET(^DIC(5,XUSIN(13),0)),U,2)
+47 SET XUSIN(14)=$PIECE(DIC1,U,4)
End DoDot:2
+48 SET XUSDATA3=XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13)_U_XUSIN(14)
+49 ;
+50 ;Phone number (place holder)
+51 SET XUSIN(15)=""
+52 ;
+53 ; Get Taxonomy and Specialty
+54 SET XUSTXY=0
+55 FOR
SET XUSTXY=$ORDER(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY))
if 'XUSTXY
QUIT
Begin DoDot:2
+56 SET XUSSPC=$PIECE($GET(^USC(8932.1,XUSTXY,0)),U,9)
+57 SET XUSTAX=$PIECE($GET(^USC(8932.1,XUSTXY,0)),U,7)
+58 IF XUSSPC'=""
Begin DoDot:3
+59 IF XUSIN(16)=""
SET XUSIN(16)=XUSSPC
QUIT
+60 SET XUSIN(16)=XUSIN(16)_";"_XUSSPC
End DoDot:3
+61 IF XUSTAX'=""
Begin DoDot:3
+62 IF XUSIN(17)=""
SET XUSIN(17)=XUSTAX
QUIT
+63 ;S XUSIN(17)=XUSIN(17)_";"_XUSTAX
+64 ;
+65 ; *** Start ^XU*8.0*548 - RBN ***
+66 ;
+67 if (XUSIN(17)'[XUSTAX)
SET XUSIN(17)=XUSIN(17)_";"_XUSTAX
+68 ;
+69 ; *** End ^XU*8.0*548 - RBN ***
End DoDot:3
End DoDot:2
+70 ;
+71 ; Federal Tax ID
+72 SET XUSIN(18)=$GET(XUSTAXID)
+73 ;
+74 ; Medicaid Part A/B
+75 SET XUSIN(19)=670899
+76 SET XUSIN(20)="VA"_$EXTRACT(SITE+10000,2,5)
+77 ;
+78 SET XUSDATA4=XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19)_U_XUSIN(20)
+79 ;
+80 ; DEA Number
+81 SET XUSIN(21)=$PIECE($GET(^DIC(4,INIEN,"DEA")),U)
+82 ;
+83 ; get Facility Type and Name
+84 SET XUSFCT=$PIECE($GET(^DIC(4,INIEN,3)),U)
+85 IF XUSFCT'=""
SET XUSFCN=$PIECE($GET(^DIC(4.1,XUSFCT,0)),U)
+86 IF $GET(XUSFCN)="PHARM"
Begin DoDot:2
+87 IF $DATA(^TMP("XUSNPIX",$JOB,INIEN))
Begin DoDot:3
+88 SET XUPHM=^TMP("XUSNPIX",$JOB,INIEN)
+89 ; get NCPDP from ^TMP
+90 SET XUSIN(22)=$PIECE($GET(XUPHM),U)
+91 ; get station number from^TMP
+92 IF $PIECE($GET(XUPHM),U,2)
SET XUSSTA=$PIECE(XUPHM,U,2)
End DoDot:3
End DoDot:2
+93 ;
+94 ; VISN Station Number
+95 SET XUSIN(23)=XUSSTA
+96 ;
+97 SET XUSDATA5=XUSIN(21)_U_XUSIN(22)_U_XUSIN(23)
+98 ;
+99 ; Get BCBS Payer ID Array
+100 KILL XUSBXID
+101 DO INSTID^XUSNPIXU(.XUSBXID)
+102 ;
+103 ; Update counter and save Entry
+104 ;
+105 SET COUNT=COUNT+1
SET TOTREC=TOTREC+1
+106 SET ^TMP(XUSRTN,$JOB,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL
+107 SET XUSIZE=XUSIZE+$LENGTH(^TMP(XUSRTN,$JOB,COUNT))
+108 IF $DATA(XUSBXID)
Begin DoDot:2
+109 SET XUSB=""
+110 FOR
SET XUSB=$ORDER(XUSBXID(XUSB))
if XUSB=""
QUIT
Begin DoDot:3
+111 SET COUNT=COUNT+1
SET TOTREC=TOTREC+1
+112 SET ^TMP(XUSRTN,$JOB,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL
+113 SET XUSIZE=XUSIZE+$LENGTH(^TMP(XUSRTN,$JOB,COUNT))
End DoDot:3
End DoDot:2
+114 KILL XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID
+115 IF XUSIZE>MAXSIZE
Begin DoDot:2
+116 DO EOF(XUSRTN)
+117 ;sending extracted data via MailMan
DO EMAIL(XUSRTN)
+118 KILL ^TMP(XUSRTN,$JOB)
+119 SET ^TMP("XUSNPIXS",$JOB,2,MSGCNT)="2^"_(COUNT-2)
+120 SET ^TMP(XUSRTN,$JOB,1)=XUSHDR
+121 SET COUNT=1
SET XUSIZE=0
End DoDot:2
End DoDot:1
+122 ;
+123 DO EOF(XUSRTN)
+124 ;
+125 ; Send the last message (if it has records)
+126 IF $GET(COUNT)>1
Begin DoDot:1
+127 ;sending extracted data via MailMan
DO EMAIL(XUSRTN)
+128 KILL ^TMP(XUSRTN,$JOB)
+129 SET ^TMP("XUSNPIXS",$JOB,2,MSGCNT)="2^"_(COUNT-2)
End DoDot:1
+130 ;
+131 ; Set Summary totals
+132 SET ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2
+133 ;
+134 KILL XUSPT,LDTCMP,SITE,XUSTAXID
+135 QUIT
+136 ;
EOF(XUSRTN) ;
+1 if COUNT=1
QUIT
+2 SET MSGCNT=MSGCNT+1
+3 SET ^TMP(XUSRTN,$JOB,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$GET(XUSPROD)_U_XUSEOL
+4 SET COUNT=COUNT+1
+5 SET ^TMP(XUSRTN,$JOB,COUNT)="END OF FILE"_U_XUSEOL
+6 QUIT
+7 ;
+8 ; Email the message
EMAIL(XUSRTN) ;
+1 NEW XMY
+2 ; Send email to designated recipients for live release
+3 ;p548
DO MAILTO^XUSNPIX1(.XMY)
+4 DO ESEND
+5 QUIT
+6 ;
ESEND NEW XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM
+1 ;
+2 SET XMTEXT="^TMP("""_XUSRTN_""","_$JOB_","
+3 SET XMSUB=$TRANSLATE($PIECE($GET(^TMP(XUSRTN,$JOB,1)),U),":")_"("_$GET(XUSPROD)_") NPI EXTRACT TYPE 2"
+4 DO ^XMD
+5 QUIT
POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain
+1 NEW XUSPOA
+2 ; No institution - return false
IF +$GET(INST)=0
QUIT 0
POA1 ;
+1 ; No IEN remaining to check - return false
IF $GET(IEN)=""
QUIT 0
+2 ; Already reviewed this IEN - possible infinite loop - return false
IF $DATA(XUSPOA(IEN))
QUIT 0
+3 SET XUSPOA(IEN)=""
+4 ; Get parent of this institution
SET XUSPOA=$PIECE($GET(^DIC(4,IEN,7,2,0)),U,2)
+5 ; Found matching institution - return true
IF XUSPOA=INST
QUIT 1
+6 ; Top level reached - return false
IF IEN=XUSPOA
QUIT 0
+7 ; Reset IEN to check next level
SET IEN=XUSPOA
+8 GOTO POA1
+9 ;
GETPHARM ;
+1 ; this subroutine retrieves data from the OUTPATIENT SITE file
+2 ; using the supported Pharmacy API PSS^PSO59.
+3 ; It takes the results and places them into a temporary
+4 ; global array that is accessed when processing data
+5 ; associated with a pharmacy institution.
+6 NEW D,DIC,XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP
+7 ;
+8 ;Fix for Remedy Ticket 217164
+9 ;Quit if Outpatient Site API routine is not loaded
+10 SET X="PSO59"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+11 ;
+12 ; remove any pre-existing nodes
KILL ^TMP($JOB,"XUS59"),^TMP("XUSNPIX",$JOB)
+13 ;IA#4827
DO PSS^PSO59(,"??","XUS59")
+14 SET XUS59DA=0
+15 ; gather data from each Outpatient site entry stored in the pharmacy
+16 ; ^TMP global and build 2nd ^TMP global for later processing
+17 FOR
SET XUS59DA=$ORDER(^TMP($JOB,"XUS59",XUS59DA))
if 'XUS59DA
QUIT
Begin DoDot:1
+18 ;
+19 ;Get Pharmacy NPI institution from API
+20 SET XUSNPIDA=$PIECE($GET(^TMP($JOB,"XUS59",XUS59DA,101)),U)
+21 ; NPI institution does not exist
if XUSNPIDA']""
QUIT
+22 ;
+23 ; Get Pharmacy Related Institution from API
+24 SET XUSRELDA=$PIECE($GET(^TMP($JOB,"XUS59",XUS59DA,100)),U)
+25 ; get station number off the related institution
+26 SET PSSTA=$PIECE($GET(^DIC(4,XUSRELDA,99)),U)
+27 ;
+28 ; Get NCPDP number
+29 ;prevent previous values being carried over
SET XUNCP=""
+30 SET X=XUSNPIDA
SET D="C"
SET DIC=9002313.56
SET DIC(0)=""
DO IX^DIC
+31 IF +Y>0
SET XUNCP=$$GET1^DIQ(9002313.56,+Y,.02)
+32 if $GET(XUNCP)=""
SET XUNCP=$PIECE($GET(^TMP($JOB,"XUS59",XUS59DA,1008)),U)
+33 ;
+34 ; rebuild the ^TMP global by NPI institution
+35 ; collect necessary data used in the 'PHARM' logic
+36 ; ncpdp#^station
SET ^TMP("XUSNPIX",$JOB,XUSNPIDA)=XUNCP_"^"_PSSTA
End DoDot:1
+37 QUIT
