XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ; Aug 30, 2022@04:49:29
;;8.0;KERNEL;**438,452,453,481,528,548,774,689**; Jul 10, 1995;Build 113
;;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="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
; storage subscript)
; Storage Global:
; ^XTMP("XUSNPIX1",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("XUSNPIX1",1) = DATA
;
; XUSNPI => Unique NPI of entry
; LDT => Last Date Run, VA Fileman Format
;
; Entry Point - TASKMAN => Run report in background using TASKMAN
;
Q
;
TASKMAN ;TASKMAN ENTRY POINT
; Process Report
N XUSRTN,DTTM,XUSPROD,XUSVER,INSMAIL,XUSNP2P,XUSTMP
;
; Check for required variables
I $G(U)=""!($G(DT)="") G EXIT
S XUSRTN="XUSNPIX1"
S DTTM=$$HTE^XLFDT($H,"2")
; Check to see if report is in use
L +^XTMP(XUSRTN):5 I '$T G EXIT
;
;Reset Summary Scratch Globals
K ^TMP("XUSNPIXS",$J)
K ^TMP("XUSNPIXT",$J)
;
; Initialize variables
D INIT(XUSRTN)
;
; Pull Station(Institution) data
D INST(XUSRTN,XUSVER,.INSMAIL)
;
;Process New Person File
D PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL)
;
; Process Institution File
D ENT^XUSNPIX2(XUSPROD,XUSVER)
;
; Process Non VA File
D ENT^XUSNPIX3(XUSPROD,XUSVER)
;
; Send summary message
D SMAIL^XUSNPIX5("XUSNPIXT",XUSPROD,XUSVER,DTTM)
;
;Standard EXIT point
EXIT ;
K DTTM,XUSVER,XUSHDR,XUSPROD,INSMAIL
;
;Kill off Scratch Globals
K ^TMP("XUSNPIXS",$J)
K ^TMP("XUSNPIXT",$J)
K ^TMP("XUSNPIXU",$J)
K ^TMP("P2P")
; Log Run Completion Time
S $P(^XTMP(XUSRTN,0),U,6)=$H
L -^XTMP(XUSRTN)
;
Q
;
INIT(XUSRTN) ; check/init variables
N XUSDESC,IBSIEN,ZN19,P2PVAL
; Set to NEXT release version from NPM
; Update the build number here.
S XUSVER="548.14" ; last patch to update the structure of the data extract (XU*8.0*548)
;
; Get production/test account flag
S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST")
;
; Reset Temporary Scratch Global
D INIT^XUSNPIXU
K ^TMP(XUSRTN)
S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete"
S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H
; Generate TMP BCBS Array
D BCBSID^XUSNPIXU
D P2PBASE^XUSNPIXU(.XUSTMP) ;XUSTMP array used for Type 1 and 2 VA
Q
;
MAILTO(XMY) ;sets the MailMan recipients based on need (XU*8.0*548)
;
;When you don't want data to go out to Austin's FSC but you need it to
;stay within the VistA's MailMan for internal testing, comment out setting
;the XMY("XXX@Q-NPS.DOMAIN.EXT) array and add your own MailMan address that
;is present in the VistA account your are on.
;When you want data to go out to Austin's FSC group, uncomment this line.
;S XMY("XXX@Q-NPS.DOMAIN.EXT")="" ;uncomment to run for live ***
S XUWHO606=$G(XUWHO606,"XXX@Q-NPS.DOMAIN.EXT") ;p774
S XMY(XUWHO606)=""
Q
;
INST(XUSRTN,XUSVER,INSMAIL) ;Pull station and Institution info
N INST,SINFO,DIC4
; Pull site info
S SINFO=$$SITE^VASITE
; Station Number
S SITE=$P(SINFO,U,3)
; Institution
S INST=$P(SINFO,U)
;
; Get institution mailing address
I INST D
. S DIC4=$G(^DIC(4,INST,4))
. S XUSNP(7)=$P(DIC4,U)
. S XUSNP(8)=$P(DIC4,U,2)
. S XUSNP(9)=$P(DIC4,U,3)
. S XUSNP(10)=$P(DIC4,U,4)
. I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2)
. S XUSNP(11)=$P(DIC4,U,5)
. S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)
S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER
;
Q
;
PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL) ;Process all New Person records
N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN
N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13,COUNT,MSGCNT,MAXSIZE,TOTREC,XUSEOL
N FND,XUSUSCT,XUSUSC1,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 NEW PERSON NPI records NPI cross ref
S XUSNPI=0
F S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI D
. S NPIEN=$O(^VA(200,"ANPI",XUSNPI,""))
. ;
. ; Init columns
. ;F XUSI=1:1:29 S XUSNP(XUSI)=""
. F XUSI=1:1:33 S XUSNP(XUSI)=""
. S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1)
. ;
. S XUSVA0=$G(^VA(200,NPIEN,0))
. S XUSVA1=$G(^VA(200,NPIEN,1))
. S XUSNAME=$P(XUSVA0,U)
. ;
. ; Break name into components
. I XUSNAME'="" D
. . S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0)
. . I $G(XLFNC("FAMILY"))="" S XLFNC("FAMILY")=$G(XUSNAME) ;p774
. . S XUSNP(2)=$G(XLFNC("GIVEN")),XUSNP(3)=$G(XLFNC("MIDDLE")),XUSNP(4)=$G(XLFNC("FAMILY")) ;p774
. . I $G(XLFNC("SUFFIX"))'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX")
. . K XLFNC
. S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4)
. ;
. S XUSNP(5)=1 ;type
. S XUSDOB=$P(XUSVA1,U,3)
. ; dob formatted as mm/dd/yyyy
. I XUSDOB D
. . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5)
. S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6)
. ;
. ; Office Phone number
. S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2)
. ;I XUSOPN'="" S XUSNP(17)=XUSOPN
. I XUSOPN'="" S XUSNP(18)=XUSOPN
. ;
. ; Servicing Provider Address
. S (XUSDIV)=0
. ; Loop through Division multiple
. F S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV D
. . S DIC4=$G(^DIC(4,XUSDIV,4))
. . S XUSNP(13)=$P(DIC4,U)
. . S XUSNP(14)=$P(DIC4,U,2)
. . S XUSNP(15)=$P(DIC4,U,3)
. . S XUSNP(16)=$P(DIC4,U,4)
. . I XUSNP(16) S XUSNP(16)=$P($G(^DIC(5,XUSNP(16),0)),U,2)
. . S XUSNP(17)=$P(DIC4,U,5)
. . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U)
. . S SPADR(XUSDIV)=XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)_U_XUSNP(17)_U_XUSNP(18)
. ;
. ; If no divisions found
. I '$D(SPADR) D
. . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)_U_XUSNP(17)_U_XUSNP(18)
. ;
. ; Degree
. S XUSNP(19)=$P($G(^VA(200,NPIEN,3.1)),U,6)
. ; Degree Code (place holder, currently empty)
. S XUSNP(20)=""
. ;
. ; get primary specialty
. S XUSPER=0
. F S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER D
. . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9)
. . ;S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7)
. . I XUSSPC'="" D
. . . ;I XUSNP(20)="" S XUSNP(20)=XUSSPC Q
. . . ;S XUSNP(20)=XUSNP(20)_";"_XUSSPC
. . . I XUSNP(21)="" S XUSNP(21)=XUSSPC Q
. . . S XUSNP(21)=XUSNP(21)_";"_XUSSPC
. . . Q
. . Q
. ;get taxonomy (primary and all secondaries)
. N XUSCLASS,XUSEXPDT ; ptr to Person class, expiration date
. S XUSPER=0
. K ^XTMP("USC1",$J)
. F S XUSPER=$O(^VA(200,NPIEN,"USC1","AD",XUSPER)) Q:'XUSPER D
. . S XUSUSC1=""
. . F S XUSUSC1=$O(^VA(200,NPIEN,"USC1","AD",XUSPER,XUSUSC1)) Q:XUSUSC1="" D
. . . S XUSCLASS=$P($G(^VA(200,NPIEN,"USC1",XUSUSC1,0)),U),XUSEXPDT=$P($G(^VA(200,NPIEN,"USC1",XUSUSC1,0)),U,3)
. . . S ^XTMP("USC1",$J,XUSUSC1)=XUSEXPDT_U_XUSCLASS
. . . Q
. . Q
. ;find primary taxonomy code
. S XUSUSC1="",FND=0,XUSUSCT=""
. F S XUSUSC1=$O(^XTMP("USC1",$J,XUSUSC1),-1) Q:XUSUSC1=""!(FND=1) D
. . I $P($G(^XTMP("USC1",$J,XUSUSC1)),U)'="" Q ; not active, expiration dt exists
. . S XUSCLASS=$P($G(^XTMP("USC1",$J,XUSUSC1)),U,2)
. . I XUSCLASS="" Q
. . S XUSNP(22)=$P($G(^USC(8932.1,XUSCLASS,0)),U,7),FND=1,XUSUSCT=XUSUSC1
. . Q
. I $D(^XTMP("USC1",$J))&$G(XUSUSCT) K ^XTMP("USC1",$J,XUSUSCT) ;remove the active taxonomy code
. S XUSUSC1=""
. F S XUSUSC1=$O(^XTMP("USC1",$J,XUSUSC1)) Q:XUSUSC1="" D
. . S XUSCLASS=$P($G(^XTMP("USC1",$J,XUSUSC1)),U,2)
. . I XUSCLASS="" Q
. . S XUSTAX=$P($G(^USC(8932.1,XUSCLASS,0)),U,7)
. . I XUSTAX'="" D
. . . ;
. . . I XUSNP(23)="" S XUSNP(23)=XUSTAX Q
. . . ;
. . . ; *** Start ^XU*8.0*548 - RBN ***
. . . ;
. . . ;S XUSNP(23)=XUSNP(23)_";"_XUSTAX
. . . S:(XUSNP(23)'[XUSTAX&(XUSTAX'=XUSNP(22))) XUSNP(23)=XUSNP(23)_";"_XUSTAX
. . . ;
. . . ; *** End ^XU*8.0*548 - RBN ***
. . . ;
. ;
. ; Tax ID
. S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2)
. I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9)
. ;S XUSNP(22)=XUSTAXID
. S XUSNP(24)=XUSTAXID
. ;
. ;S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)
. S XUSDATA2=XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)_U_XUSNP(23)_U_XUSNP(24)
. ;
. ; Medicare Part A/B
. ;S XUSNP(23)=670899
. ;S XUSNP(24)="VA"_$E(SITE+10000,2,5)
. S XUSNP(25)=670899
. S XUSNP(26)="VA"_$E(SITE+10000,2,5)
. ;
. ; State License
. S XUSSTL=0
. F S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL D
. . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2)
. . I XUSSTLN'="" D
. . . ;I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q
. . . ;S XUSNP(25)=XUSNP(25)_";"_XUSSTLN
. . . I XUSNP(27)="" S XUSNP(27)=XUSSTLN Q
. . . ;S XUSNP(27)=XUSNP(27)_";"_XUSSTLN
. ;S XUSNP(28)=$P($G(^VA(200,NPIEN,"PS")),U,2)
. ; *689 - DEA #
. S XUSNP(28)=$$PRDEA^XUSER(NPIEN)
. ;
. ;S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26)
. S XUSDATA2=XUSDATA2_U_XUSNP(25)_U_XUSNP(26)_U_XUSNP(27)_U_XUSNP(28)
. ;
. ; Add logic for STATUS and CREATION/TERMINATION DATE from file #200
. S XUSNP(29)="",XUSNP(30)=""
. S XUSNP(29)=$P($G(^VA(200,NPIEN,0)),U,11)
. I $G(XUSNP(29))'="" S XUSNP(30)=$$FMTE^XLFDT(XUSNP(29),5),XUSNP(29)="TERMINATED"
. I $G(XUSNP(29))="" S XUSNP(29)=$P($G(^VA(200,NPIEN,1)),U,7),XUSNP(30)=$$FMTE^XLFDT(XUSNP(29),5),XUSNP(29)="ACTIVE"
. ;
. S XUSDATA2=XUSDATA2_U_XUSNP(29)_U_XUSNP(30)
. ;
. ; Get BCBS Payer ID Array
. K XUSBXID
. D PRACID^XUSNPIXU(NPIEN,.XUSBXID)
. ;
. ; Save entry to ^TMP and update count
. N XUSB,XUSB1
. S XUSDIV=0
. F S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV D
. . ;
. . ; Pay to Provider Address NP7-12
. . I $D(XUSTMP("P2P",XUSDIV)) D
. . . S $P(XUSDATA1,U,7)=$P($G(^IBE(350.9,1,19,$G(XUSTMP("P2P",XUSDIV)),0)),U,2)
. . . S $P(XUSDATA1,U,8)=$P($G(^IBE(350.9,1,19,$G(XUSTMP("P2P",XUSDIV)),1)),U,1)
. . . S $P(XUSDATA1,U,9)=$P($G(^IBE(350.9,1,19,$G(XUSTMP("P2P",XUSDIV)),1)),U,2)
. . . S $P(XUSDATA1,U,10)=$P($G(^IBE(350.9,1,19,$G(XUSTMP("P2P",XUSDIV)),1)),U,3)
. . . S $P(XUSDATA1,U,11)=$P($G(^IBE(350.9,1,19,$G(XUSTMP("P2P",XUSDIV)),1)),U,4)
. . . I $P(XUSDATA1,U,11)?1N.N S $P(XUSDATA1,U,11)=$P($G(^DIC(5,$P(XUSDATA1,U,11),0)),U,2)
. . . S $P(XUSDATA1,U,12)=$P($G(^IBE(350.9,1,19,$G(XUSTMP("P2P",XUSDIV)),1)),U,5)
. . . Q
. . I '$D(XUSTMP("P2P",XUSDIV)) D
. . . I '$D(XUSTMP("P2P","DEFAULT")) D Q
. . . . F I=7:1:12 S $P(XUSDATA1,U,I)=""
. . . N XUSDEF
. . . S XUSDEF=$G(XUSTMP("P2P","DEFAULT"))
. . . S $P(XUSDATA1,U,7)=$P($G(^IBE(350.9,1,19,XUSDEF,0)),U,2)
. . . S $P(XUSDATA1,U,8)=$P($G(^IBE(350.9,1,19,XUSDEF,1)),U,1)
. . . S $P(XUSDATA1,U,9)=$P($G(^IBE(350.9,1,19,XUSDEF,1)),U,2)
. . . S $P(XUSDATA1,U,10)=$P($G(^IBE(350.9,1,19,XUSDEF,1)),U,3)
. . . S $P(XUSDATA1,U,11)=$P($G(^IBE(350.9,1,19,XUSDEF,1)),U,4)
. . . I $P(XUSDATA1,U,11)?1N.N S $P(XUSDATA1,U,11)=$P($G(^DIC(5,$P(XUSDATA1,U,11),0)),U,2)
. . . S $P(XUSDATA1,U,12)=$P($G(^IBE(350.9,1,19,XUSDEF,1)),U,5)
. . . Q
. . ;
. . S COUNT=COUNT+1,TOTREC=TOTREC+1
. . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL
. . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
. . ; Check BCBS Id array
. . I $D(XUSBXID) D
. . . S XUSB=""
. . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D
. . . . S XUSB1=$G(XUSBXID(XUSB)) I XUSB1'="" S XUSB1="^"_XUSB1 ;add p528
. . . . S COUNT=COUNT+1,TOTREC=TOTREC+1
. . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_$$TRIM^XLFSTR(XUSB)_XUSB1_U_XUSEOL ;add _XUSB1 p 528
. . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT))
. K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA
. I XUSIZE>MAXSIZE D
. . D EOF(XUSRTN)
. . D EMAIL^XUSNPIX5(XUSRTN) ;transmitting extract data via MailMan
. . K ^TMP(XUSRTN,$J)
. . S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(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^XUSNPIX5(XUSRTN) ;transmitting extract data via MailMan
.K ^TMP(XUSRTN,$J)
.S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2)
;
; Set summary totals
S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H
S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4)
S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM
K INSMAIL,SITE
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_DTTM_U_$G(XUSPROD)_U_XUSEOL
S COUNT=COUNT+1
S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSNPIX1 13263 printed Sep 23, 2025@19:48:59 Page 2
XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ; Aug 30, 2022@04:49:29
+1 ;;8.0;KERNEL;**438,452,453,481,528,548,774,689**; Jul 10, 1995;Build 113
+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="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP
+14 ; storage subscript)
+15 ; Storage Global:
+16 ; ^XTMP("XUSNPIX1",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("XUSNPIX1",1) = DATA
+26 ;
+27 ; XUSNPI => Unique NPI of entry
+28 ; LDT => Last Date Run, VA Fileman Format
+29 ;
+30 ; Entry Point - TASKMAN => Run report in background using TASKMAN
+31 ;
+32 QUIT
+33 ;
TASKMAN ;TASKMAN ENTRY POINT
+1 ; Process Report
+2 NEW XUSRTN,DTTM,XUSPROD,XUSVER,INSMAIL,XUSNP2P,XUSTMP
+3 ;
+4 ; Check for required variables
+5 IF $GET(U)=""!($GET(DT)="")
GOTO EXIT
+6 SET XUSRTN="XUSNPIX1"
+7 SET DTTM=$$HTE^XLFDT($HOROLOG,"2")
+8 ; Check to see if report is in use
+9 LOCK +^XTMP(XUSRTN):5
IF '$TEST
GOTO EXIT
+10 ;
+11 ;Reset Summary Scratch Globals
+12 KILL ^TMP("XUSNPIXS",$JOB)
+13 KILL ^TMP("XUSNPIXT",$JOB)
+14 ;
+15 ; Initialize variables
+16 DO INIT(XUSRTN)
+17 ;
+18 ; Pull Station(Institution) data
+19 DO INST(XUSRTN,XUSVER,.INSMAIL)
+20 ;
+21 ;Process New Person File
+22 DO PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL)
+23 ;
+24 ; Process Institution File
+25 DO ENT^XUSNPIX2(XUSPROD,XUSVER)
+26 ;
+27 ; Process Non VA File
+28 DO ENT^XUSNPIX3(XUSPROD,XUSVER)
+29 ;
+30 ; Send summary message
+31 DO SMAIL^XUSNPIX5("XUSNPIXT",XUSPROD,XUSVER,DTTM)
+32 ;
+33 ;Standard EXIT point
EXIT ;
+1 KILL DTTM,XUSVER,XUSHDR,XUSPROD,INSMAIL
+2 ;
+3 ;Kill off Scratch Globals
+4 KILL ^TMP("XUSNPIXS",$JOB)
+5 KILL ^TMP("XUSNPIXT",$JOB)
+6 KILL ^TMP("XUSNPIXU",$JOB)
+7 KILL ^TMP("P2P")
+8 ; Log Run Completion Time
+9 SET $PIECE(^XTMP(XUSRTN,0),U,6)=$HOROLOG
+10 LOCK -^XTMP(XUSRTN)
+11 ;
+12 QUIT
+13 ;
INIT(XUSRTN) ; check/init variables
+1 NEW XUSDESC,IBSIEN,ZN19,P2PVAL
+2 ; Set to NEXT release version from NPM
+3 ; Update the build number here.
+4 ; last patch to update the structure of the data extract (XU*8.0*548)
SET XUSVER="548.14"
+5 ;
+6 ; Get production/test account flag
+7 SET XUSPROD=$SELECT($$PROD^XUPROD(1):"PROD",1:"TEST")
+8 ;
+9 ; Reset Temporary Scratch Global
+10 DO INIT^XUSNPIXU
+11 KILL ^TMP(XUSRTN)
+12 SET XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete"
+13 SET ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$HOROLOG
+14 ; Generate TMP BCBS Array
+15 DO BCBSID^XUSNPIXU
+16 ;XUSTMP array used for Type 1 and 2 VA
DO P2PBASE^XUSNPIXU(.XUSTMP)
+17 QUIT
+18 ;
MAILTO(XMY) ;sets the MailMan recipients based on need (XU*8.0*548)
+1 ;
+2 ;When you don't want data to go out to Austin's FSC but you need it to
+3 ;stay within the VistA's MailMan for internal testing, comment out setting
+4 ;the XMY("XXX@Q-NPS.DOMAIN.EXT) array and add your own MailMan address that
+5 ;is present in the VistA account your are on.
+6 ;When you want data to go out to Austin's FSC group, uncomment this line.
+7 ;S XMY("XXX@Q-NPS.DOMAIN.EXT")="" ;uncomment to run for live ***
+8 ;p774
SET XUWHO606=$GET(XUWHO606,"XXX@Q-NPS.DOMAIN.EXT")
+9 SET XMY(XUWHO606)=""
+10 QUIT
+11 ;
INST(XUSRTN,XUSVER,INSMAIL) ;Pull station and Institution info
+1 NEW INST,SINFO,DIC4
+2 ; Pull site info
+3 SET SINFO=$$SITE^VASITE
+4 ; Station Number
+5 SET SITE=$PIECE(SINFO,U,3)
+6 ; Institution
+7 SET INST=$PIECE(SINFO,U)
+8 ;
+9 ; Get institution mailing address
+10 IF INST
Begin DoDot:1
+11 SET DIC4=$GET(^DIC(4,INST,4))
+12 SET XUSNP(7)=$PIECE(DIC4,U)
+13 SET XUSNP(8)=$PIECE(DIC4,U,2)
+14 SET XUSNP(9)=$PIECE(DIC4,U,3)
+15 SET XUSNP(10)=$PIECE(DIC4,U,4)
+16 IF XUSNP(10)
SET XUSNP(10)=$PIECE($GET(^DIC(5,XUSNP(10),0)),U,2)
+17 SET XUSNP(11)=$PIECE(DIC4,U,5)
+18 SET INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)
End DoDot:1
+19 SET XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER
+20 ;
+21 QUIT
+22 ;
PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL) ;Process all New Person records
+1 NEW XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN
+2 NEW XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13,COUNT,MSGCNT,MAXSIZE,TOTREC,XUSEOL
+3 NEW FND,XUSUSCT,XUSUSC1,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 ;
+14 ; Loop through NEW PERSON NPI records NPI cross ref
+15 SET XUSNPI=0
+16 FOR
SET XUSNPI=$ORDER(^VA(200,"ANPI",XUSNPI))
if 'XUSNPI
QUIT
Begin DoDot:1
+17 SET NPIEN=$ORDER(^VA(200,"ANPI",XUSNPI,""))
+18 ;
+19 ; Init columns
+20 ;F XUSI=1:1:29 S XUSNP(XUSI)=""
+21 FOR XUSI=1:1:33
SET XUSNP(XUSI)=""
+22 SET XUSNP(1)=XUSNPI
SET XUSDATA1=XUSNP(1)
+23 ;
+24 SET XUSVA0=$GET(^VA(200,NPIEN,0))
+25 SET XUSVA1=$GET(^VA(200,NPIEN,1))
+26 SET XUSNAME=$PIECE(XUSVA0,U)
+27 ;
+28 ; Break name into components
+29 IF XUSNAME'=""
Begin DoDot:2
+30 SET XLFNC=XUSNAME
DO FORMAT^XLFNAME7(.XLFNC,,,,0)
+31 ;p774
IF $GET(XLFNC("FAMILY"))=""
SET XLFNC("FAMILY")=$GET(XUSNAME)
+32 ;p774
SET XUSNP(2)=$GET(XLFNC("GIVEN"))
SET XUSNP(3)=$GET(XLFNC("MIDDLE"))
SET XUSNP(4)=$GET(XLFNC("FAMILY"))
+33 IF $GET(XLFNC("SUFFIX"))'=""
SET XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX")
+34 KILL XLFNC
End DoDot:2
+35 SET XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4)
+36 ;
+37 ;type
SET XUSNP(5)=1
+38 SET XUSDOB=$PIECE(XUSVA1,U,3)
+39 ; dob formatted as mm/dd/yyyy
+40 IF XUSDOB
Begin DoDot:2
+41 SET XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5)
End DoDot:2
+42 SET XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6)
+43 ;
+44 ; Office Phone number
+45 SET XUSOPN=$PIECE($GET(^VA(200,NPIEN,.13)),U,2)
+46 ;I XUSOPN'="" S XUSNP(17)=XUSOPN
+47 IF XUSOPN'=""
SET XUSNP(18)=XUSOPN
+48 ;
+49 ; Servicing Provider Address
+50 SET (XUSDIV)=0
+51 ; Loop through Division multiple
+52 FOR
SET XUSDIV=$ORDER(^VA(200,NPIEN,2,XUSDIV))
if 'XUSDIV
QUIT
Begin DoDot:2
+53 SET DIC4=$GET(^DIC(4,XUSDIV,4))
+54 SET XUSNP(13)=$PIECE(DIC4,U)
+55 SET XUSNP(14)=$PIECE(DIC4,U,2)
+56 SET XUSNP(15)=$PIECE(DIC4,U,3)
+57 SET XUSNP(16)=$PIECE(DIC4,U,4)
+58 IF XUSNP(16)
SET XUSNP(16)=$PIECE($GET(^DIC(5,XUSNP(16),0)),U,2)
+59 SET XUSNP(17)=$PIECE(DIC4,U,5)
+60 SET XUSSTA(XUSDIV)=$PIECE($GET(^DIC(4,XUSDIV,99)),U)
+61 SET SPADR(XUSDIV)=XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)_U_XUSNP(17)_U_XUSNP(18)
End DoDot:2
+62 ;
+63 ; If no divisions found
+64 IF '$DATA(SPADR)
Begin DoDot:2
+65 SET XUSSTA(9999)="N/A"
SET SPADR(9999)=XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16)_U_XUSNP(17)_U_XUSNP(18)
End DoDot:2
+66 ;
+67 ; Degree
+68 SET XUSNP(19)=$PIECE($GET(^VA(200,NPIEN,3.1)),U,6)
+69 ; Degree Code (place holder, currently empty)
+70 SET XUSNP(20)=""
+71 ;
+72 ; get primary specialty
+73 SET XUSPER=0
+74 FOR
SET XUSPER=$ORDER(^VA(200,NPIEN,"USC1","B",XUSPER))
if 'XUSPER
QUIT
Begin DoDot:2
+75 SET XUSSPC=$PIECE($GET(^USC(8932.1,XUSPER,0)),U,9)
+76 ;S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7)
+77 IF XUSSPC'=""
Begin DoDot:3
+78 ;I XUSNP(20)="" S XUSNP(20)=XUSSPC Q
+79 ;S XUSNP(20)=XUSNP(20)_";"_XUSSPC
+80 IF XUSNP(21)=""
SET XUSNP(21)=XUSSPC
QUIT
+81 SET XUSNP(21)=XUSNP(21)_";"_XUSSPC
+82 QUIT
End DoDot:3
+83 QUIT
End DoDot:2
+84 ;get taxonomy (primary and all secondaries)
+85 ; ptr to Person class, expiration date
NEW XUSCLASS,XUSEXPDT
+86 SET XUSPER=0
+87 KILL ^XTMP("USC1",$JOB)
+88 FOR
SET XUSPER=$ORDER(^VA(200,NPIEN,"USC1","AD",XUSPER))
if 'XUSPER
QUIT
Begin DoDot:2
+89 SET XUSUSC1=""
+90 FOR
SET XUSUSC1=$ORDER(^VA(200,NPIEN,"USC1","AD",XUSPER,XUSUSC1))
if XUSUSC1=""
QUIT
Begin DoDot:3
+91 SET XUSCLASS=$PIECE($GET(^VA(200,NPIEN,"USC1",XUSUSC1,0)),U)
SET XUSEXPDT=$PIECE($GET(^VA(200,NPIEN,"USC1",XUSUSC1,0)),U,3)
+92 SET ^XTMP("USC1",$JOB,XUSUSC1)=XUSEXPDT_U_XUSCLASS
+93 QUIT
End DoDot:3
+94 QUIT
End DoDot:2
+95 ;find primary taxonomy code
+96 SET XUSUSC1=""
SET FND=0
SET XUSUSCT=""
+97 FOR
SET XUSUSC1=$ORDER(^XTMP("USC1",$JOB,XUSUSC1),-1)
if XUSUSC1=""!(FND=1)
QUIT
Begin DoDot:2
+98 ; not active, expiration dt exists
IF $PIECE($GET(^XTMP("USC1",$JOB,XUSUSC1)),U)'=""
QUIT
+99 SET XUSCLASS=$PIECE($GET(^XTMP("USC1",$JOB,XUSUSC1)),U,2)
+100 IF XUSCLASS=""
QUIT
+101 SET XUSNP(22)=$PIECE($GET(^USC(8932.1,XUSCLASS,0)),U,7)
SET FND=1
SET XUSUSCT=XUSUSC1
+102 QUIT
End DoDot:2
+103 ;remove the active taxonomy code
IF $DATA(^XTMP("USC1",$JOB))&$GET(XUSUSCT)
KILL ^XTMP("USC1",$JOB,XUSUSCT)
+104 SET XUSUSC1=""
+105 FOR
SET XUSUSC1=$ORDER(^XTMP("USC1",$JOB,XUSUSC1))
if XUSUSC1=""
QUIT
Begin DoDot:2
+106 SET XUSCLASS=$PIECE($GET(^XTMP("USC1",$JOB,XUSUSC1)),U,2)
+107 IF XUSCLASS=""
QUIT
+108 SET XUSTAX=$PIECE($GET(^USC(8932.1,XUSCLASS,0)),U,7)
+109 IF XUSTAX'=""
Begin DoDot:3
+110 ;
+111 IF XUSNP(23)=""
SET XUSNP(23)=XUSTAX
QUIT
+112 ;
+113 ; *** Start ^XU*8.0*548 - RBN ***
+114 ;
+115 ;S XUSNP(23)=XUSNP(23)_";"_XUSTAX
+116 if (XUSNP(23)'[XUSTAX&(XUSTAX'=XUSNP(22)))
SET XUSNP(23)=XUSNP(23)_";"_XUSTAX
+117 ;
+118 ; *** End ^XU*8.0*548 - RBN ***
+119 ;
End DoDot:3
End DoDot:2
+120 ;
+121 ; Tax ID
+122 SET XUSTAXID=$PIECE($GET(^VA(200,NPIEN,"TPB")),U,2)
+123 IF XUSTAXID=""
SET XUSTAXID=$PIECE($GET(^VA(200,NPIEN,1)),U,9)
+124 ;S XUSNP(22)=XUSTAXID
+125 SET XUSNP(24)=XUSTAXID
+126 ;
+127 ;S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)
+128 SET XUSDATA2=XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22)_U_XUSNP(23)_U_XUSNP(24)
+129 ;
+130 ; Medicare Part A/B
+131 ;S XUSNP(23)=670899
+132 ;S XUSNP(24)="VA"_$E(SITE+10000,2,5)
+133 SET XUSNP(25)=670899
+134 SET XUSNP(26)="VA"_$EXTRACT(SITE+10000,2,5)
+135 ;
+136 ; State License
+137 SET XUSSTL=0
+138 FOR
SET XUSSTL=$ORDER(^VA(200,NPIEN,"PS1",XUSSTL))
if 'XUSSTL
QUIT
Begin DoDot:2
+139 SET XUSSTLN=$PIECE($GET(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2)
+140 IF XUSSTLN'=""
Begin DoDot:3
+141 ;I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q
+142 ;S XUSNP(25)=XUSNP(25)_";"_XUSSTLN
+143 IF XUSNP(27)=""
SET XUSNP(27)=XUSSTLN
QUIT
+144 ;S XUSNP(27)=XUSNP(27)_";"_XUSSTLN
End DoDot:3
End DoDot:2
+145 ;S XUSNP(28)=$P($G(^VA(200,NPIEN,"PS")),U,2)
+146 ; *689 - DEA #
+147 SET XUSNP(28)=$$PRDEA^XUSER(NPIEN)
+148 ;
+149 ;S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26)
+150 SET XUSDATA2=XUSDATA2_U_XUSNP(25)_U_XUSNP(26)_U_XUSNP(27)_U_XUSNP(28)
+151 ;
+152 ; Add logic for STATUS and CREATION/TERMINATION DATE from file #200
+153 SET XUSNP(29)=""
SET XUSNP(30)=""
+154 SET XUSNP(29)=$PIECE($GET(^VA(200,NPIEN,0)),U,11)
+155 IF $GET(XUSNP(29))'=""
SET XUSNP(30)=$$FMTE^XLFDT(XUSNP(29),5)
SET XUSNP(29)="TERMINATED"
+156 IF $GET(XUSNP(29))=""
SET XUSNP(29)=$PIECE($GET(^VA(200,NPIEN,1)),U,7)
SET XUSNP(30)=$$FMTE^XLFDT(XUSNP(29),5)
SET XUSNP(29)="ACTIVE"
+157 ;
+158 SET XUSDATA2=XUSDATA2_U_XUSNP(29)_U_XUSNP(30)
+159 ;
+160 ; Get BCBS Payer ID Array
+161 KILL XUSBXID
+162 DO PRACID^XUSNPIXU(NPIEN,.XUSBXID)
+163 ;
+164 ; Save entry to ^TMP and update count
+165 NEW XUSB,XUSB1
+166 SET XUSDIV=0
+167 FOR
SET XUSDIV=$ORDER(SPADR(XUSDIV))
if 'XUSDIV
QUIT
Begin DoDot:2
+168 ;
+169 ; Pay to Provider Address NP7-12
+170 IF $DATA(XUSTMP("P2P",XUSDIV))
Begin DoDot:3
+171 SET $PIECE(XUSDATA1,U,7)=$PIECE($GET(^IBE(350.9,1,19,$GET(XUSTMP("P2P",XUSDIV)),0)),U,2)
+172 SET $PIECE(XUSDATA1,U,8)=$PIECE($GET(^IBE(350.9,1,19,$GET(XUSTMP("P2P",XUSDIV)),1)),U,1)
+173 SET $PIECE(XUSDATA1,U,9)=$PIECE($GET(^IBE(350.9,1,19,$GET(XUSTMP("P2P",XUSDIV)),1)),U,2)
+174 SET $PIECE(XUSDATA1,U,10)=$PIECE($GET(^IBE(350.9,1,19,$GET(XUSTMP("P2P",XUSDIV)),1)),U,3)
+175 SET $PIECE(XUSDATA1,U,11)=$PIECE($GET(^IBE(350.9,1,19,$GET(XUSTMP("P2P",XUSDIV)),1)),U,4)
+176 IF $PIECE(XUSDATA1,U,11)?1N.N
SET $PIECE(XUSDATA1,U,11)=$PIECE($GET(^DIC(5,$PIECE(XUSDATA1,U,11),0)),U,2)
+177 SET $PIECE(XUSDATA1,U,12)=$PIECE($GET(^IBE(350.9,1,19,$GET(XUSTMP("P2P",XUSDIV)),1)),U,5)
+178 QUIT
End DoDot:3
+179 IF '$DATA(XUSTMP("P2P",XUSDIV))
Begin DoDot:3
+180 IF '$DATA(XUSTMP("P2P","DEFAULT"))
Begin DoDot:4
+181 FOR I=7:1:12
SET $PIECE(XUSDATA1,U,I)=""
End DoDot:4
QUIT
+182 NEW XUSDEF
+183 SET XUSDEF=$GET(XUSTMP("P2P","DEFAULT"))
+184 SET $PIECE(XUSDATA1,U,7)=$PIECE($GET(^IBE(350.9,1,19,XUSDEF,0)),U,2)
+185 SET $PIECE(XUSDATA1,U,8)=$PIECE($GET(^IBE(350.9,1,19,XUSDEF,1)),U,1)
+186 SET $PIECE(XUSDATA1,U,9)=$PIECE($GET(^IBE(350.9,1,19,XUSDEF,1)),U,2)
+187 SET $PIECE(XUSDATA1,U,10)=$PIECE($GET(^IBE(350.9,1,19,XUSDEF,1)),U,3)
+188 SET $PIECE(XUSDATA1,U,11)=$PIECE($GET(^IBE(350.9,1,19,XUSDEF,1)),U,4)
+189 IF $PIECE(XUSDATA1,U,11)?1N.N
SET $PIECE(XUSDATA1,U,11)=$PIECE($GET(^DIC(5,$PIECE(XUSDATA1,U,11),0)),U,2)
+190 SET $PIECE(XUSDATA1,U,12)=$PIECE($GET(^IBE(350.9,1,19,XUSDEF,1)),U,5)
+191 QUIT
End DoDot:3
+192 ;
+193 SET COUNT=COUNT+1
SET TOTREC=TOTREC+1
+194 SET ^TMP(XUSRTN,$JOB,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL
+195 SET XUSIZE=XUSIZE+$LENGTH(^TMP(XUSRTN,$JOB,COUNT))
+196 ; Check BCBS Id array
+197 IF $DATA(XUSBXID)
Begin DoDot:3
+198 SET XUSB=""
+199 FOR
SET XUSB=$ORDER(XUSBXID(XUSB))
if XUSB=""
QUIT
Begin DoDot:4
+200 ;add p528
SET XUSB1=$GET(XUSBXID(XUSB))
IF XUSB1'=""
SET XUSB1="^"_XUSB1
+201 SET COUNT=COUNT+1
SET TOTREC=TOTREC+1
+202 ;add _XUSB1 p 528
SET ^TMP(XUSRTN,$JOB,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_$$TRIM^XLFSTR(XUSB)_XUSB1_U_XUSEOL
+203 SET XUSIZE=XUSIZE+$LENGTH(^TMP(XUSRTN,$JOB,COUNT))
End DoDot:4
End DoDot:3
End DoDot:2
+204 KILL XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA
+205 IF XUSIZE>MAXSIZE
Begin DoDot:2
+206 DO EOF(XUSRTN)
+207 ;transmitting extract data via MailMan
DO EMAIL^XUSNPIX5(XUSRTN)
+208 KILL ^TMP(XUSRTN,$JOB)
+209 SET ^TMP("XUSNPIXS",$JOB,1,MSGCNT)="1^"_(COUNT-2)
+210 SET ^TMP(XUSRTN,$JOB,1)=XUSHDR
+211 SET COUNT=1
SET XUSIZE=0
End DoDot:2
End DoDot:1
+212 DO EOF(XUSRTN)
+213 ;
+214 ; Send the last message (if it has records)
+215 IF $GET(COUNT)>1
Begin DoDot:1
+216 ;transmitting extract data via MailMan
DO EMAIL^XUSNPIX5(XUSRTN)
+217 KILL ^TMP(XUSRTN,$JOB)
+218 SET ^TMP("XUSNPIXS",$JOB,1,MSGCNT)="1^"_(COUNT-2)
End DoDot:1
+219 ;
+220 ; Set summary totals
+221 SET ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$HOROLOG
+222 SET ^XTMP("XUSNPIXT","H")=$PIECE(XUSHDR,U,1,4)
+223 SET ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM
+224 KILL INSMAIL,SITE
+225 QUIT
+226 ;
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_DTTM_U_$GET(XUSPROD)_U_XUSEOL
+4 SET COUNT=COUNT+1
+5 SET ^TMP(XUSRTN,$JOB,COUNT)="END OF FILE"_U_XUSEOL
+6 QUIT
