- 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 Feb 18, 2025@23:39:12 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