PSONVAP2 ;HPS/DSK - Non-VA Provider Updates ;May 16, 2018@16:00
;;7.0;OUTPATIENT PHARMACY;**481**;DEC 1997;Build 31
;
;Note to KERNEL developers:
; This routine was written with patch XU*8*659, but not distributed as part of the patch.
; It is being given to VistA Maintenance contractors to be renamed as a PSO routine
; to run with monthly updates for VACAA data maintenance.
;
; Post Installation Routine for Outpatient Pharmacy VACAA non-VA provider updates
; EXTERNAL REFERENCES
; $$PROD^XUPROD - IA #4440 (Supported)
; $$AESDECR^XUSHSH - IA #6189 (Supported)
; $$B64DECD^XUSHSH - IA #6189 (Supported)
; $$VACAA^XUESSO4 - IA #6230 (Private)
; PARENT^XUAF4 - IA #2171 (Supported)
; FTG^%ZISH - IA #2320 (Supported)
; $$ADDNPI^XUSNPI - IA #6937 (Private)
; $$QI^XUSNPI - IA #4532 (Controlled Subscription)
; NEW PERSON FILE - IA #10060 (Supported)
; NEW PERSON PHARMACY FIELDS - IA #6889 (Private)
; SERVICE/SECTION FILE - IA #2250 (Private)
; %DT - IA #10003 (Supported)
;
Q
;
EN ;load non-VA providers into file 200
N AUTHCODE,PSOVISN,PSOIMPORT,PSOPROD,PSOFILE
N PSODT,PSOTIM,PSOQUIT,PSOJOB,PSOSERV
S PSOPROD=$$PROD^XUPROD
I 'PSOPROD D Q
. W !!,"This option may only be invoked in a production environment."
. W !,"This is a test environment."
. W !!,"If you are testing, the variable PSOPROD must be manipulated in debug mode."
;
I PSOPROD,$$PROD^XUPROD=0 D
. W !!,"*** This is a test environment but the Prod/Test environment indicator "
. W !,"*** indicates this is a production environment for testing purposes."
. W !!,"*** Make sure you have the routine ZKESSO4 which is applicable for your site"
. W !,"*** or test environment.",!!
. S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR
;
S PSOQUIT=0
D CONSIDER
Q:PSOQUIT
D INIT
;notifying user to only attempt file load for the site's VISN
W !!,"Your site VISN is: ",PSOVISN,"."
W !,"Only providers for your VISN may be imported."
S PSOQUIT=0
;
D IMPORT
Q:PSOQUIT
D SERV
Q:PSOQUIT
D TASK
Q
;
CONSIDER ;
N DIR,DUOUT,DTOUT,Y
W !!,"Considerations before invoking this option:"
W !!,"TITLE (#3.1) file:"
W !,?5,"Have the titles ""HN NON-VA PROVIDER"" and ""TW NON-VA PROVIDER"""
W !,?5,"been defined in the TITLE (#3.1) file in this system?"
W !,?5,"It is optional to have the titles defined."
W !,?5,"However, the providers loaded by this patch will have no titles"
W !,?5,"listed in CPRS if these titles are not pre-defined prior to importing"
W !,?5,"the non-VA provider information included in this update."
W !!,"SERVICE/SECTION (#49) file:"
W !,?5,"Determine whether an entry for the SERVICE/SECTION (#29) field"
W !,?5,"should be populated during the import."
W !,?5,"It is optional to populate the SERVICE/SECTION (#29) field."
W !,?5,"Your site may wish to define a new SERVICE/SECTION (#49) file entry"
W !,?5,"such as ""NON-VA COMMUNITY CARE"".",!
K DIR S DIR(0)="Y",DIR("B")="NO"
S DIR("?")="Enter ""Y"" if you wish to proceed with non-VA provider filing."
S DIR("A")="Do you wish to proceed"
D ^DIR K DIR
I 'Y!($D(DUOUT))!($D(DTOUT)) S PSOQUIT=1
Q
;
INIT ;initialize
N PSOUVISN,VIEN,PSOSUB,VIEN,PSOJOBN,PSOA
;
;This exact setting of AUTHCODE is checked for by VistA routine XUESSO4
;The value was determined by a Kernel developer.
S AUTHCODE="This entry point is for VACAA only. No morons."
;
;PSODT and PSOTM are used as unique subscripts in ^XTMP.
;Not using PSOTM since ^XTMP needs to remain for possible troubleshooting
;and a user might invoke this option multiple times under the same job number
;when processing files for multiple states within the VISN.
;
S PSOJOB="PSONONVA "_$J
I $D(^XTMP(PSOJOB)) D
. S PSOJOBN=$J
. F PSOA=1:1:500 Q:'$D(^XTMP(PSOJOB)) D
. . S PSOJOBN=PSOJOBN+1
. . S PSOJOB="PSONONVA "_PSOJOBN
;
;not checking to see if the 500th attempt is unused
;surely this routine won't be run 500 times using the
;same job number within 60 days
;
S PSODT=$$FMTHL7^XLFDT(DT)
S PSOTM=$P($$NOW^XLFDT,".",2)
;PSOTM should never be null, but just making sure
I PSOTM="" S PSOTM=1
;
;Initialize trace globals which can be used for future research/troubleshooting if need be.
;The trace globals will purge automatically in 60 days by the VistA ^XTMP purging task.
;
;Purging just in case the ^XTMP entries exist.
F PSOSUB="RAW DATA","DUPNPI","PRENPI","DUPNAME","PROBLEM","SUCCESS","ZNPI" D
. K ^XTMP(PSOJOB,PSODT,PSOSUB,PSOTM)
S ^XTMP(PSOJOB,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^Non-VA Provider Updates"
;
;Initialize indexes
;
S ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)="Name^Degree^Sex^ST 1^Street 1^Street 2^City^State^ZIP^"
S ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)=^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)_"NPI^Tax ID^TW/HN^DEA#^DEA Exp. Date^DETOX/Maint ID^"
S ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)=^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)_"Sched II Narc^Sched II Non-Narc^Sched III Narc^Sched III Non-Narc^Sched IV^Sched V"
;
;what is site's VISN
D PARENT^XUAF4("PSOUVISN","`"_DUZ(2),"VISN")
;
;The check below is needed when testing in MNTVBB.
;It will not affect sites and other test environments.
I DUZ(2)'=16066 S VIEN=$O(PSOUVISN("P",0)) S PSOVISN=$TR($P($G(PSOUVISN("P",VIEN)),U),"VISN ")
;
;line below is for testing in MNTVBB test environment
;keep the line for possible future changes so that the next developer does
;not have to research the custom VISN value in MNTVBB
I DUZ(2)=16066 S PSOVISN=19
Q
;
SERV ;
N DIC,DTOUT,DUOUT,Y
W !!,"Press ENTER if the SERVICE/SECTION (#29) field should not be populated.",!
S DIC("A")="Which SERVICE/SECTION (#29) field entry should be used? "
S DIC(0)="AEQM"
S DIC="^DIC(49,"
D ^DIC
S PSOSERV=$S(+Y>0:+Y,1:"")
I $D(DTOUT)!$D(DUOUT) S PSOQUIT=1
Q
;
IMPORT ;
N PSOTMP1,PSOTMP2,DIR,DUOUT,DTOUT,Y
S DIR(0)="FA",DIR("A")="Directory name "
S DIR("B")=""
D ^DIR
I $D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
;
S PSODIR=Y
S DIR(0)="FA",DIR("A")="File Name "
S DIR("B")=""
D ^DIR
I $D(DTOUT)!$D(DUOUT) S PSOQUIT=1 Q
S PSOFILE=Y
;
;Validate filename to make sure VISN is correct
I $P(PSOFILE,"_",3)'=PSOVISN D Q
. W !!,"This file pertains to VISN ",$P(PSOFILE,"_",3)
. W !,"Only files for your VISN of ",PSOVISN
. W !,"may be imported.",!
. S PSOQUIT=1
;
;convert CSV into lower case if user specified upper case
S $P(PSOFILE,".",2)=$TR($P(PSOFILE,".",2),"CSV","csv")
;
S PSOIMPORT=$$FTG^%ZISH(PSODIR,PSOFILE,$NA(^XTMP($TR(PSOFILE,"_",""),PSOTM,1,0)),3)
I +PSOIMPORT<1 D Q
. W !!," **** FILE: ",PSOFILE," not found in directory ****"
. W !!," **** ",PSODIR,". ****",!
. S PSOQUIT=1
;
;Check to make sure the first row is a header row and
;that the headers are correct.
;This is another step to make sure the spreadsheets were properly
;prepared and that field values will file into the correct fields.
S PSOTMP1=$P($G(^XTMP($TR(PSOFILE,"_",""),PSOTM,1,0)),",",1,8)
S PSOTMP2=$P($G(^XTMP($TR(PSOFILE,"_",""),PSOTM,1,0)),",",9,23)
D CHKHDR
S ^XTMP(PSOFILE,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^Non-VA Provider Updates"
Q
;
TASK ;task processing
;
N ZTSAVE,%ZIS,ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTIO,POP
S ZTSAVE("PSOJOB")=""
S ZTSAVE("PSOPROD")=""
S ZTSAVE("PSODT")=""
S ZTSAVE("PSOTM")=""
S ZTSAVE("PSOSERV")=""
S PSOFILE=$TR(PSOFILE,"_","")
S ZTSAVE("PSOFILE")=""
S ZTSAVE("PSOVISN")=""
S ZTSAVE("AUTHCODE")=""
S PSOSAVDUZ=$S($O(^VA(200,"B","TASKMAN,PROXY USER",0))]"":$O(^VA(200,"B","TASKMAN,PROXY USER",0)),1:DUZ)
S ZTSAVE("PSOSAVDUZ")=""
S ZTRTN="PROC^PSONVAP2"
S ZTDESC="PSO NON-VA PROVIDER IMPORT"
S ZTIO=""
D ^%ZTLOAD
W:$D(ZTSK) !!,?5,"PSO NON-VA PROVIDER IMPORT TASKED: ",$G(ZTSK)
Q
;
PROC ;
N PSOTMP1,PSOTMP2,PSOXA,PSOXB,PSOXC,PSOXD,PSOXE,PSOXF
N PSOSEQ,PSOQUIT
S DUZ=PSOSAVDUZ
S PSOXA=1,(PSOXB,PSOXC,PSOXD,PSOXE,PSOXF)=0
S PSOQUIT=0,PSOSEQ=1
;don't check the first row since it is a header row
F S PSOSEQ=$O(^XTMP(PSOFILE,PSOTM,PSOSEQ)) Q:PSOSEQ="" Q:PSOQUIT D
. ;
. ;Throttle the import process in case to avoid possible
. ;system (journaling, etc.) issues due to thousands of new entries
. ;being filed
. I PSOSEQ#1000=0 H 15
. ;
. ;Need to break line up into two variables due to possible
. ;lengthy address lines
. ;
. S PSOTMP1=$P($G(^XTMP(PSOFILE,PSOTM,PSOSEQ,0)),",",1,8)
. S PSOTMP2=$P($G(^XTMP(PSOFILE,PSOTM,PSOSEQ,0)),",",9,23)
. ;
. ;San Diego field test site had apparent end of file issues
. ;in which the last line of ^XTMP was in the format "\000\000\000..."
. ;In all instances, PSOTMP2 was null. Inserting the check below
. ;in case other sites have the same issue.
. ;
. I PSOTMP2']"" Q
. ;
. D CHECK
D MAIL^PSONVAP3
D END
Q
;
CHKHDR ;
;
;Make sure required column headers are correct so data will be filed into correct
;New Person (#200) file fields.
; A - Provider_Sur_Name
; B - Provider_First_Name
; C - Provider_Suffix
; D - Degree
; E - Sex
; F - Address Line
; G - Address Line 2
; H - City
; I - State
; J - Zip
; K - VISN
; L - Pvdr_NPI
; M - Tax_Id__TIN_
; N - TW_or_HN
; O - DEA_Number
; P - DEA_Expiration_Date
; Q - Detox_Number
; R - Schedule2
; S - Schedule2N
; T - Schedule3
; U - Schedule3N
; V - Schedule4
; W - Schedule5
;
N PSOI,PSOTITLE
F PSOI=1:1:8 S PSOTITLE=$P(PSOTMP1,",",PSOI) D Q:PSOQUIT
. I PSOTITLE'[$P($T(HEADER+PSOI),";",4) D HDRERR
Q:PSOQUIT
F PSOI=1:1:15 S PSOTITLE=$P(PSOTMP2,",",PSOI) D Q:PSOQUIT
. I PSOTITLE'[$P($T(HEADER+PSOI+8),";",4) D HDRERR
Q
;
HDRERR ;Header row is incorrect
N DIR
W !!,"**** Header row is missing or incorrect in file ",PSOFILE,". ****"
W !!," Submit a ticket to Tier 2 to report this issue.",!
K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
S PSOQUIT=1
Q
;
;;1;Provider_Sur_Name
;;2;Provider_First_Name
;;3;Provider_Suffix
;;4;Degree
;;5;Sex
;;6;Address_Line
;;7;Address_Line_2
;;8;City
;;9;State
;;10;Zip
;;11;VISN
;;12;Pvdr_NPI
;;13;Tax_ID__TIN_
;;14;TW_or_HN
;;15;DEA_Number
;;16;DEA_Expiration_Date
;;17;Detox_Number
;;18;Schedule2
;;19;Schedule2N
;;20;Schedule3
;;21;Schedule3N
;;22;Schedule4
;;23;Schedule5
Q
;
CHECK ;analyze data and determine whether to file
;
N PSOI,X,PSONPI,PSODUZ
;decrypt NPI, Tax ID, and DEA#
F PSOI=4,5,7 I $P(PSOTMP2,",",PSOI)]"" D
. S $P(PSOTMP2,",",PSOI)=$$AESDECR^XUSHSH($$B64DECD^XUSHSH($P(PSOTMP2,",",PSOI)),"BaDcefXXijklmnop")
;File raw data if future troubleshooting needed
;^XTMP is indexed by date in case the site needs to perform research after the
;MailMan messages have been deleted
;
S PSOXA=PSOXA+1
S ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,PSOXA)=PSOTMP1_","_PSOTMP2
;
;check to see if the provider NPI is already on file
S PSONPI=$P(PSOTMP2,",",4)
S PSODUZ=$$FNDUSR(PSONPI)
;
;was NPI already on file at site before this patch was received? If so, quit
I +PSODUZ>0,'$D(^XTMP(PSOJOB,PSOTM,"NPI",PSONPI)) D Q
. I $D(^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)) Q
. S PSOXB=PSOXB+1
. S ^XTMP(PSOJOB,PSODT,"PRENPI",PSOTM,PSOXB)=PSOTMP1_","_PSOTMP2
. S ^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)=""
;
;Has NPI been received multiple times in this provider load?
;If so, store duplicates in trace global and send in MailMan message
I +PSODUZ>0,$D(^XTMP(PSOJOB,PSOTM,"NPI",PSONPI)) D Q
. S PSOXC=PSOXC+1
. S ^XTMP(PSOJOB,PSODT,"DUPNPI",PSOTM,PSOXC)=PSOTMP1_","_PSOTMP2
. S ^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)=""
;
Q:+PSODUZ>0
;
;is Provider Name already on file
I $$CHKNAME() D Q
. I $D(^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)) Q
. S PSOXD=PSOXD+1
. S ^XTMP(PSOJOB,PSODT,"DUPNAME",PSOTM,PSOXD)=PSOTMP1_","_PSOTMP2
. S ^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)=""
;
D FILE200
Q
;
FILE200 ;
;Call Kernel interface to NEW PERSON file (#200) add/edit
N PSOI,INARRAY,PSONEW,PSOFLG,PSONPI2,PSODUZ2
S PSOFLG=0
S INARRAY(0)=PSOVISN
;name
S INARRAY(1)=$P(PSOTMP1,",")_","_$P(PSOTMP1,",",2)_$S($P(PSOTMP1,",",3)]"":" ",1:"")_$P(PSOTMP1,",",3)
;degree
S INARRAY(2)=$P(PSOTMP1,",",4)
;sex
S INARRAY(3)=$P(PSOTMP1,",",5)
;address line one
S INARRAY(4)=$P(PSOTMP1,",",6)
;address line two
S INARRAY(5)=$P(PSOTMP1,",",7)
;city
S INARRAY(7)=$P(PSOTMP1,",",8)
;state
S INARRAY(8)=$P(PSOTMP2,",")
;zip
;file import / export strips leading 0 off Zip codes
S INARRAY(9)=$S($L($P(PSOTMP2,",",2))<5:$E("00000",1,5-$L($P(PSOTMP2,",",2)))_$P(PSOTMP2,",",2),1:$P(PSOTMP2,",",2))
;skipping $P(PSOTMP2,",",3) because the VISN number is not filed
;
;NPI
S INARRAY(10)=$P(PSOTMP2,",",4)
;Tax ID
;file import/export strips leading 0's off Tax ID
S INARRAY(11)=$S($L($P(PSOTMP2,",",5))<9:$E("000000000",1,9-$L($P(PSOTMP2,",",5)))_$P(PSOTMP2,",",5),1:$P(PSOTMP2,",",5))
;DEA#
S INARRAY(12)=$P(PSOTMP2,",",7)
;Subject Organization text and ID
S INARRAY(13)="Veteran Care in the Community"
;The space is needed after N/A to pass four character requirement
;in XUESSO2.
S INARRAY(14)="N/A "
;
;The additional check for production ensures that duplicate errors won't
;be generated during testing.
I PSOPROD,$$PROD^XUPROD=1 S PSONEW=$$VACAA^XUESSO4(.INARRAY,AUTHCODE)
;
;If PSONEW is less than 1, XUESSO4 refused to file, so there is no need
;to continue attempting to file additional data for this provider.
I +PSONEW<1 D PROB Q
D NPI(+PSONEW,INARRAY(10)),MORE,DEL
Q
;
PROB ;problem detected after FileMan call
N PSOXERR,PSOTXT,PSOPAD
S PSOXE=PSOXE+1
S PSOTXT=$S($P(PSONEW,U,2)]"":$P(PSONEW,U,2),1:"No reason text available.")
I PSOFLG=1 S PSOTXT="Check ^XTMP(""PSONONVA ""_[job number],[date],""PROBLEM"""
S PSOPAD=$E(" ",1,55-$L(PSOTXT))
S ^XTMP(PSOJOB,PSODT,"PROBLEM",PSOTM,PSOXE)=$E(PSOTXT,1,55)_PSOPAD_$E(INARRAY(1),1,20)
M ^XTMP(PSOJOB,PSODT,"PROBLEM",PSOTM,PSOXE)=INARRAY
I PSOFLG=1 D
. M ^XTMP(PSOJOB,PSODT,"PROBLEM",PSOTM,PSOXE)=PSOERR
Q
;
NPI(PSODUZ2,PSONPI2) ;This call needed to file EFFECTIVE DATE/TIME and sub-fields
N PSOCHK
S PSOCHK=$$ADDNPI^XUSNPI("Individual_ID",+PSODUZ2,PSONPI2,$$NOW^XLFDT(),1)
Q
;
MORE ;File additional fields
;approved by IA #6889
N PSOFDR,PSOERR,X,Y
;
;PSOFLG is used in PROB if there are FileMan errors
S PSOFLG=1
;
;Service/Section
S PSOFDR(200,+PSONEW_",",29)=PSOSERV
;
;Remarks
S PSOFDR(200,+PSONEW_",",53.9)=$P(PSOTMP2,",",6)_" NON-VA PROVIDER"
;DEA Expiration Date (convert to VistA date format if not null)
S X=$P(PSOTMP2,",",8)
I X]"" D
. D ^%DT
. S PSOFDR(200,+PSONEW_",",747.44)=Y
;Detox/Maintenance ID Number
S PSOFDR(200,+PSONEW_",",53.11)=$P(PSOTMP2,",",9)
;
;Convert "Y" or "N" for Schedule fields to "1" or "0"
;Schedule II Narcotic
S PSOFDR(200,+PSONEW_",",55.1)=$S($P(PSOTMP2,",",10)="Y":1,1:0)
;Schedule II Non-Narcotic
S PSOFDR(200,+PSONEW_",",55.2)=$S($P(PSOTMP2,",",11)="Y":1,1:0)
;Schedule III Narcotic
S PSOFDR(200,+PSONEW_",",55.3)=$S($P(PSOTMP2,",",12)="Y":1,1:0)
;Schedule III Non-Narcotic
S PSOFDR(200,+PSONEW_",",55.4)=$S($P(PSOTMP2,",",13)="Y":1,1:0)
;Schedule IV
S PSOFDR(200,+PSONEW_",",55.5)=$S($P(PSOTMP2,",",14)="Y":1,1:0)
;Schedule V
S PSOFDR(200,+PSONEW_",",55.6)=$S($P(PSOTMP2,",",15)="Y":1,1:0)
D UPDATE^DIE("","PSOFDR","IEN","PSOERR")
I $D(PSOERR("DIERR")) D PROB
;
;continue filing additional fields even if there was a problem
;with previous call since the provider has information filed by this time.
;
K PSOFDR,PSOERR
S PSOFDR(200,+PSONEW_",",8)=$P(PSOTMP2,",",6)_" NON-VA PROVIDER"
D UPDATE^DIE("E","PSOFDR","IEN","PSOERR")
I $D(PSOERR("DIERR")) D PROB
;
;if Title is not defined in the TITLE (#3.1) file, file as text
K PSOERR
I $P($G(^VA(200,+PSONEW,0)),"^",9)="" D
. D UPDATE^DIE("U","PSOFDR","IEN","PSOERR")
. I $D(PSOERR("DIERR")) D PROB
S PSOXF=PSOXF+1
S ^XTMP(PSOJOB,PSOTM,"NPI",INARRAY(10))=""
S ^XTMP(PSOJOB,PSODT,"SUCCESS",PSOTM,PSOXF)=+PSONEW_$E(" ",1,15-$L(+PSONEW))_$E(INARRAY(1),1,35)
K INARRAY
;
Q
;
DEL ;Delete key XUORES which was filed by XUESSO4
;UNCOMMENT if it is decided later to remove the key
;N DIC,X,DIK,DA
;S DIK="^VA(200,"_+PSONEW_",51,"
;S DA(1)=+PSONEW
;S DIC="^DIC(19.1,",DIC(0)="MZ",X="XUORES" D ^DIC
;S DA=+Y
;D ^DIK
Q
;
FNDUSR(PSONPI) ;see if provider already on file
;A previous version of this routine checked to see if the
;provider is active. However, if the NPI is already on file,
;Kernel routine XUESSO4 will file data into the New Person IEN
;on file. This can create issues because old and new information
;is on file within the same IEN.
N PSOATTRIB
S PSOATTRIB(8)=PSONPI ; NPI
S PSODUZ=$$QI^XUSNPI(PSOATTRIB(8))
Q $S(PSODUZ'=0:1,1:0)
;
CHKNAME() ;is provider name already in New Person file
;if so, store data in trace global and send MailMan message
N PSONAME
;do not validate suffix to be on safe side
S PSONAME=$P(PSOTMP1,",",1,2)
I $D(^VA(200,"B",PSONAME)) Q 1
Q 0
;
END ;clean up
;
K ^XTMP(PSOJOB,PSOTM)
K ^XTMP(PSOJOB,PSODT,"ZNPI")
K ^XTMP(PSOFILE,PSOTM)
K PSODIR,PSOFILE,PSOSAVDUZ,PSOTM
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONVAP2 17676 printed Nov 22, 2024@17:41:33 Page 2
PSONVAP2 ;HPS/DSK - Non-VA Provider Updates ;May 16, 2018@16:00
+1 ;;7.0;OUTPATIENT PHARMACY;**481**;DEC 1997;Build 31
+2 ;
+3 ;Note to KERNEL developers:
+4 ; This routine was written with patch XU*8*659, but not distributed as part of the patch.
+5 ; It is being given to VistA Maintenance contractors to be renamed as a PSO routine
+6 ; to run with monthly updates for VACAA data maintenance.
+7 ;
+8 ; Post Installation Routine for Outpatient Pharmacy VACAA non-VA provider updates
+9 ; EXTERNAL REFERENCES
+10 ; $$PROD^XUPROD - IA #4440 (Supported)
+11 ; $$AESDECR^XUSHSH - IA #6189 (Supported)
+12 ; $$B64DECD^XUSHSH - IA #6189 (Supported)
+13 ; $$VACAA^XUESSO4 - IA #6230 (Private)
+14 ; PARENT^XUAF4 - IA #2171 (Supported)
+15 ; FTG^%ZISH - IA #2320 (Supported)
+16 ; $$ADDNPI^XUSNPI - IA #6937 (Private)
+17 ; $$QI^XUSNPI - IA #4532 (Controlled Subscription)
+18 ; NEW PERSON FILE - IA #10060 (Supported)
+19 ; NEW PERSON PHARMACY FIELDS - IA #6889 (Private)
+20 ; SERVICE/SECTION FILE - IA #2250 (Private)
+21 ; %DT - IA #10003 (Supported)
+22 ;
+23 QUIT
+24 ;
EN ;load non-VA providers into file 200
+1 NEW AUTHCODE,PSOVISN,PSOIMPORT,PSOPROD,PSOFILE
+2 NEW PSODT,PSOTIM,PSOQUIT,PSOJOB,PSOSERV
+3 SET PSOPROD=$$PROD^XUPROD
+4 IF 'PSOPROD
Begin DoDot:1
+5 WRITE !!,"This option may only be invoked in a production environment."
+6 WRITE !,"This is a test environment."
+7 WRITE !!,"If you are testing, the variable PSOPROD must be manipulated in debug mode."
End DoDot:1
QUIT
+8 ;
+9 IF PSOPROD
IF $$PROD^XUPROD=0
Begin DoDot:1
+10 WRITE !!,"*** This is a test environment but the Prod/Test environment indicator "
+11 WRITE !,"*** indicates this is a production environment for testing purposes."
+12 WRITE !!,"*** Make sure you have the routine ZKESSO4 which is applicable for your site"
+13 WRITE !,"*** or test environment.",!!
+14 SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
End DoDot:1
+15 ;
+16 SET PSOQUIT=0
+17 DO CONSIDER
+18 if PSOQUIT
QUIT
+19 DO INIT
+20 ;notifying user to only attempt file load for the site's VISN
+21 WRITE !!,"Your site VISN is: ",PSOVISN,"."
+22 WRITE !,"Only providers for your VISN may be imported."
+23 SET PSOQUIT=0
+24 ;
+25 DO IMPORT
+26 if PSOQUIT
QUIT
+27 DO SERV
+28 if PSOQUIT
QUIT
+29 DO TASK
+30 QUIT
+31 ;
CONSIDER ;
+1 NEW DIR,DUOUT,DTOUT,Y
+2 WRITE !!,"Considerations before invoking this option:"
+3 WRITE !!,"TITLE (#3.1) file:"
+4 WRITE !,?5,"Have the titles ""HN NON-VA PROVIDER"" and ""TW NON-VA PROVIDER"""
+5 WRITE !,?5,"been defined in the TITLE (#3.1) file in this system?"
+6 WRITE !,?5,"It is optional to have the titles defined."
+7 WRITE !,?5,"However, the providers loaded by this patch will have no titles"
+8 WRITE !,?5,"listed in CPRS if these titles are not pre-defined prior to importing"
+9 WRITE !,?5,"the non-VA provider information included in this update."
+10 WRITE !!,"SERVICE/SECTION (#49) file:"
+11 WRITE !,?5,"Determine whether an entry for the SERVICE/SECTION (#29) field"
+12 WRITE !,?5,"should be populated during the import."
+13 WRITE !,?5,"It is optional to populate the SERVICE/SECTION (#29) field."
+14 WRITE !,?5,"Your site may wish to define a new SERVICE/SECTION (#49) file entry"
+15 WRITE !,?5,"such as ""NON-VA COMMUNITY CARE"".",!
+16 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
+17 SET DIR("?")="Enter ""Y"" if you wish to proceed with non-VA provider filing."
+18 SET DIR("A")="Do you wish to proceed"
+19 DO ^DIR
KILL DIR
+20 IF 'Y!($DATA(DUOUT))!($DATA(DTOUT))
SET PSOQUIT=1
+21 QUIT
+22 ;
INIT ;initialize
+1 NEW PSOUVISN,VIEN,PSOSUB,VIEN,PSOJOBN,PSOA
+2 ;
+3 ;This exact setting of AUTHCODE is checked for by VistA routine XUESSO4
+4 ;The value was determined by a Kernel developer.
+5 SET AUTHCODE="This entry point is for VACAA only. No morons."
+6 ;
+7 ;PSODT and PSOTM are used as unique subscripts in ^XTMP.
+8 ;Not using PSOTM since ^XTMP needs to remain for possible troubleshooting
+9 ;and a user might invoke this option multiple times under the same job number
+10 ;when processing files for multiple states within the VISN.
+11 ;
+12 SET PSOJOB="PSONONVA "_$JOB
+13 IF $DATA(^XTMP(PSOJOB))
Begin DoDot:1
+14 SET PSOJOBN=$JOB
+15 FOR PSOA=1:1:500
if '$DATA(^XTMP(PSOJOB))
QUIT
Begin DoDot:2
+16 SET PSOJOBN=PSOJOBN+1
+17 SET PSOJOB="PSONONVA "_PSOJOBN
End DoDot:2
End DoDot:1
+18 ;
+19 ;not checking to see if the 500th attempt is unused
+20 ;surely this routine won't be run 500 times using the
+21 ;same job number within 60 days
+22 ;
+23 SET PSODT=$$FMTHL7^XLFDT(DT)
+24 SET PSOTM=$PIECE($$NOW^XLFDT,".",2)
+25 ;PSOTM should never be null, but just making sure
+26 IF PSOTM=""
SET PSOTM=1
+27 ;
+28 ;Initialize trace globals which can be used for future research/troubleshooting if need be.
+29 ;The trace globals will purge automatically in 60 days by the VistA ^XTMP purging task.
+30 ;
+31 ;Purging just in case the ^XTMP entries exist.
+32 FOR PSOSUB="RAW DATA","DUPNPI","PRENPI","DUPNAME","PROBLEM","SUCCESS","ZNPI"
Begin DoDot:1
+33 KILL ^XTMP(PSOJOB,PSODT,PSOSUB,PSOTM)
End DoDot:1
+34 SET ^XTMP(PSOJOB,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^Non-VA Provider Updates"
+35 ;
+36 ;Initialize indexes
+37 ;
+38 SET ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)="Name^Degree^Sex^ST 1^Street 1^Street 2^City^State^ZIP^"
+39 SET ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)=^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)_"NPI^Tax ID^TW/HN^DEA#^DEA Exp. Date^DETOX/Maint ID^"
+40 SET ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)=^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,1)_"Sched II Narc^Sched II Non-Narc^Sched III Narc^Sched III Non-Narc^Sched IV^Sched V"
+41 ;
+42 ;what is site's VISN
+43 DO PARENT^XUAF4("PSOUVISN","`"_DUZ(2),"VISN")
+44 ;
+45 ;The check below is needed when testing in MNTVBB.
+46 ;It will not affect sites and other test environments.
+47 IF DUZ(2)'=16066
SET VIEN=$ORDER(PSOUVISN("P",0))
SET PSOVISN=$TRANSLATE($PIECE($GET(PSOUVISN("P",VIEN)),U),"VISN ")
+48 ;
+49 ;line below is for testing in MNTVBB test environment
+50 ;keep the line for possible future changes so that the next developer does
+51 ;not have to research the custom VISN value in MNTVBB
+52 IF DUZ(2)=16066
SET PSOVISN=19
+53 QUIT
+54 ;
SERV ;
+1 NEW DIC,DTOUT,DUOUT,Y
+2 WRITE !!,"Press ENTER if the SERVICE/SECTION (#29) field should not be populated.",!
+3 SET DIC("A")="Which SERVICE/SECTION (#29) field entry should be used? "
+4 SET DIC(0)="AEQM"
+5 SET DIC="^DIC(49,"
+6 DO ^DIC
+7 SET PSOSERV=$SELECT(+Y>0:+Y,1:"")
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
+9 QUIT
+10 ;
IMPORT ;
+1 NEW PSOTMP1,PSOTMP2,DIR,DUOUT,DTOUT,Y
+2 SET DIR(0)="FA"
SET DIR("A")="Directory name "
+3 SET DIR("B")=""
+4 DO ^DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+6 ;
+7 SET PSODIR=Y
+8 SET DIR(0)="FA"
SET DIR("A")="File Name "
+9 SET DIR("B")=""
+10 DO ^DIR
+11 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSOQUIT=1
QUIT
+12 SET PSOFILE=Y
+13 ;
+14 ;Validate filename to make sure VISN is correct
+15 IF $PIECE(PSOFILE,"_",3)'=PSOVISN
Begin DoDot:1
+16 WRITE !!,"This file pertains to VISN ",$PIECE(PSOFILE,"_",3)
+17 WRITE !,"Only files for your VISN of ",PSOVISN
+18 WRITE !,"may be imported.",!
+19 SET PSOQUIT=1
End DoDot:1
QUIT
+20 ;
+21 ;convert CSV into lower case if user specified upper case
+22 SET $PIECE(PSOFILE,".",2)=$TRANSLATE($PIECE(PSOFILE,".",2),"CSV","csv")
+23 ;
+24 SET PSOIMPORT=$$FTG^%ZISH(PSODIR,PSOFILE,$NAME(^XTMP($TRANSLATE(PSOFILE,"_",""),PSOTM,1,0)),3)
+25 IF +PSOIMPORT<1
Begin DoDot:1
+26 WRITE !!," **** FILE: ",PSOFILE," not found in directory ****"
+27 WRITE !!," **** ",PSODIR,". ****",!
+28 SET PSOQUIT=1
End DoDot:1
QUIT
+29 ;
+30 ;Check to make sure the first row is a header row and
+31 ;that the headers are correct.
+32 ;This is another step to make sure the spreadsheets were properly
+33 ;prepared and that field values will file into the correct fields.
+34 SET PSOTMP1=$PIECE($GET(^XTMP($TRANSLATE(PSOFILE,"_",""),PSOTM,1,0)),",",1,8)
+35 SET PSOTMP2=$PIECE($GET(^XTMP($TRANSLATE(PSOFILE,"_",""),PSOTM,1,0)),",",9,23)
+36 DO CHKHDR
+37 SET ^XTMP(PSOFILE,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^Non-VA Provider Updates"
+38 QUIT
+39 ;
TASK ;task processing
+1 ;
+2 NEW ZTSAVE,%ZIS,ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTIO,POP
+3 SET ZTSAVE("PSOJOB")=""
+4 SET ZTSAVE("PSOPROD")=""
+5 SET ZTSAVE("PSODT")=""
+6 SET ZTSAVE("PSOTM")=""
+7 SET ZTSAVE("PSOSERV")=""
+8 SET PSOFILE=$TRANSLATE(PSOFILE,"_","")
+9 SET ZTSAVE("PSOFILE")=""
+10 SET ZTSAVE("PSOVISN")=""
+11 SET ZTSAVE("AUTHCODE")=""
+12 SET PSOSAVDUZ=$SELECT($ORDER(^VA(200,"B","TASKMAN,PROXY USER",0))]"":$ORDER(^VA(200,"B","TASKMAN,PROXY USER",0)),1:DUZ)
+13 SET ZTSAVE("PSOSAVDUZ")=""
+14 SET ZTRTN="PROC^PSONVAP2"
+15 SET ZTDESC="PSO NON-VA PROVIDER IMPORT"
+16 SET ZTIO=""
+17 DO ^%ZTLOAD
+18 if $DATA(ZTSK)
WRITE !!,?5,"PSO NON-VA PROVIDER IMPORT TASKED: ",$GET(ZTSK)
+19 QUIT
+20 ;
PROC ;
+1 NEW PSOTMP1,PSOTMP2,PSOXA,PSOXB,PSOXC,PSOXD,PSOXE,PSOXF
+2 NEW PSOSEQ,PSOQUIT
+3 SET DUZ=PSOSAVDUZ
+4 SET PSOXA=1
SET (PSOXB,PSOXC,PSOXD,PSOXE,PSOXF)=0
+5 SET PSOQUIT=0
SET PSOSEQ=1
+6 ;don't check the first row since it is a header row
+7 FOR
SET PSOSEQ=$ORDER(^XTMP(PSOFILE,PSOTM,PSOSEQ))
if PSOSEQ=""
QUIT
if PSOQUIT
QUIT
Begin DoDot:1
+8 ;
+9 ;Throttle the import process in case to avoid possible
+10 ;system (journaling, etc.) issues due to thousands of new entries
+11 ;being filed
+12 IF PSOSEQ#1000=0
HANG 15
+13 ;
+14 ;Need to break line up into two variables due to possible
+15 ;lengthy address lines
+16 ;
+17 SET PSOTMP1=$PIECE($GET(^XTMP(PSOFILE,PSOTM,PSOSEQ,0)),",",1,8)
+18 SET PSOTMP2=$PIECE($GET(^XTMP(PSOFILE,PSOTM,PSOSEQ,0)),",",9,23)
+19 ;
+20 ;San Diego field test site had apparent end of file issues
+21 ;in which the last line of ^XTMP was in the format "\000\000\000..."
+22 ;In all instances, PSOTMP2 was null. Inserting the check below
+23 ;in case other sites have the same issue.
+24 ;
+25 IF PSOTMP2']""
QUIT
+26 ;
+27 DO CHECK
End DoDot:1
+28 DO MAIL^PSONVAP3
+29 DO END
+30 QUIT
+31 ;
CHKHDR ;
+1 ;
+2 ;Make sure required column headers are correct so data will be filed into correct
+3 ;New Person (#200) file fields.
+4 ; A - Provider_Sur_Name
+5 ; B - Provider_First_Name
+6 ; C - Provider_Suffix
+7 ; D - Degree
+8 ; E - Sex
+9 ; F - Address Line
+10 ; G - Address Line 2
+11 ; H - City
+12 ; I - State
+13 ; J - Zip
+14 ; K - VISN
+15 ; L - Pvdr_NPI
+16 ; M - Tax_Id__TIN_
+17 ; N - TW_or_HN
+18 ; O - DEA_Number
+19 ; P - DEA_Expiration_Date
+20 ; Q - Detox_Number
+21 ; R - Schedule2
+22 ; S - Schedule2N
+23 ; T - Schedule3
+24 ; U - Schedule3N
+25 ; V - Schedule4
+26 ; W - Schedule5
+27 ;
+28 NEW PSOI,PSOTITLE
+29 FOR PSOI=1:1:8
SET PSOTITLE=$PIECE(PSOTMP1,",",PSOI)
Begin DoDot:1
+30 IF PSOTITLE'[$PIECE($TEXT(HEADER+PSOI),";",4)
DO HDRERR
End DoDot:1
if PSOQUIT
QUIT
+31 if PSOQUIT
QUIT
+32 FOR PSOI=1:1:15
SET PSOTITLE=$PIECE(PSOTMP2,",",PSOI)
Begin DoDot:1
+33 IF PSOTITLE'[$PIECE($TEXT(HEADER+PSOI+8),";",4)
DO HDRERR
End DoDot:1
if PSOQUIT
QUIT
+34 QUIT
+35 ;
HDRERR ;Header row is incorrect
+1 NEW DIR
+2 WRITE !!,"**** Header row is missing or incorrect in file ",PSOFILE,". ****"
+3 WRITE !!," Submit a ticket to Tier 2 to report this issue.",!
+4 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+5 SET PSOQUIT=1
+6 QUIT
+7 ;
+1 ;;1;Provider_Sur_Name
+2 ;;2;Provider_First_Name
+3 ;;3;Provider_Suffix
+4 ;;4;Degree
+5 ;;5;Sex
+6 ;;6;Address_Line
+7 ;;7;Address_Line_2
+8 ;;8;City
+9 ;;9;State
+10 ;;10;Zip
+11 ;;11;VISN
+12 ;;12;Pvdr_NPI
+13 ;;13;Tax_ID__TIN_
+14 ;;14;TW_or_HN
+15 ;;15;DEA_Number
+16 ;;16;DEA_Expiration_Date
+17 ;;17;Detox_Number
+18 ;;18;Schedule2
+19 ;;19;Schedule2N
+20 ;;20;Schedule3
+21 ;;21;Schedule3N
+22 ;;22;Schedule4
+23 ;;23;Schedule5
+24 QUIT
+25 ;
CHECK ;analyze data and determine whether to file
+1 ;
+2 NEW PSOI,X,PSONPI,PSODUZ
+3 ;decrypt NPI, Tax ID, and DEA#
+4 FOR PSOI=4,5,7
IF $PIECE(PSOTMP2,",",PSOI)]""
Begin DoDot:1
+5 SET $PIECE(PSOTMP2,",",PSOI)=$$AESDECR^XUSHSH($$B64DECD^XUSHSH($PIECE(PSOTMP2,",",PSOI)),"BaDcefXXijklmnop")
End DoDot:1
+6 ;File raw data if future troubleshooting needed
+7 ;^XTMP is indexed by date in case the site needs to perform research after the
+8 ;MailMan messages have been deleted
+9 ;
+10 SET PSOXA=PSOXA+1
+11 SET ^XTMP(PSOJOB,PSODT,"RAW DATA",PSOTM,PSOXA)=PSOTMP1_","_PSOTMP2
+12 ;
+13 ;check to see if the provider NPI is already on file
+14 SET PSONPI=$PIECE(PSOTMP2,",",4)
+15 SET PSODUZ=$$FNDUSR(PSONPI)
+16 ;
+17 ;was NPI already on file at site before this patch was received? If so, quit
+18 IF +PSODUZ>0
IF '$DATA(^XTMP(PSOJOB,PSOTM,"NPI",PSONPI))
Begin DoDot:1
+19 IF $DATA(^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI))
QUIT
+20 SET PSOXB=PSOXB+1
+21 SET ^XTMP(PSOJOB,PSODT,"PRENPI",PSOTM,PSOXB)=PSOTMP1_","_PSOTMP2
+22 SET ^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)=""
End DoDot:1
QUIT
+23 ;
+24 ;Has NPI been received multiple times in this provider load?
+25 ;If so, store duplicates in trace global and send in MailMan message
+26 IF +PSODUZ>0
IF $DATA(^XTMP(PSOJOB,PSOTM,"NPI",PSONPI))
Begin DoDot:1
+27 SET PSOXC=PSOXC+1
+28 SET ^XTMP(PSOJOB,PSODT,"DUPNPI",PSOTM,PSOXC)=PSOTMP1_","_PSOTMP2
+29 SET ^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)=""
End DoDot:1
QUIT
+30 ;
+31 if +PSODUZ>0
QUIT
+32 ;
+33 ;is Provider Name already on file
+34 IF $$CHKNAME()
Begin DoDot:1
+35 IF $DATA(^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI))
QUIT
+36 SET PSOXD=PSOXD+1
+37 SET ^XTMP(PSOJOB,PSODT,"DUPNAME",PSOTM,PSOXD)=PSOTMP1_","_PSOTMP2
+38 SET ^XTMP(PSOJOB,PSODT,"ZNPI",PSONPI)=""
End DoDot:1
QUIT
+39 ;
+40 DO FILE200
+41 QUIT
+42 ;
FILE200 ;
+1 ;Call Kernel interface to NEW PERSON file (#200) add/edit
+2 NEW PSOI,INARRAY,PSONEW,PSOFLG,PSONPI2,PSODUZ2
+3 SET PSOFLG=0
+4 SET INARRAY(0)=PSOVISN
+5 ;name
+6 SET INARRAY(1)=$PIECE(PSOTMP1,",")_","_$PIECE(PSOTMP1,",",2)_$SELECT($PIECE(PSOTMP1,",",3)]"":" ",1:"")_$PIECE(PSOTMP1,",",3)
+7 ;degree
+8 SET INARRAY(2)=$PIECE(PSOTMP1,",",4)
+9 ;sex
+10 SET INARRAY(3)=$PIECE(PSOTMP1,",",5)
+11 ;address line one
+12 SET INARRAY(4)=$PIECE(PSOTMP1,",",6)
+13 ;address line two
+14 SET INARRAY(5)=$PIECE(PSOTMP1,",",7)
+15 ;city
+16 SET INARRAY(7)=$PIECE(PSOTMP1,",",8)
+17 ;state
+18 SET INARRAY(8)=$PIECE(PSOTMP2,",")
+19 ;zip
+20 ;file import / export strips leading 0 off Zip codes
+21 SET INARRAY(9)=$SELECT($LENGTH($PIECE(PSOTMP2,",",2))<5:$EXTRACT("00000",1,5-$LENGTH($PIECE(PSOTMP2,",",2)))_$PIECE(PSOTMP2,",",2),1:$PIECE(PSOTMP2,",",2))
+22 ;skipping $P(PSOTMP2,",",3) because the VISN number is not filed
+23 ;
+24 ;NPI
+25 SET INARRAY(10)=$PIECE(PSOTMP2,",",4)
+26 ;Tax ID
+27 ;file import/export strips leading 0's off Tax ID
+28 SET INARRAY(11)=$SELECT($LENGTH($PIECE(PSOTMP2,",",5))<9:$EXTRACT("000000000",1,9-$LENGTH($PIECE(PSOTMP2,",",5)))_$PIECE(PSOTMP2,",",5),1:$PIECE(PSOTMP2,",",5))
+29 ;DEA#
+30 SET INARRAY(12)=$PIECE(PSOTMP2,",",7)
+31 ;Subject Organization text and ID
+32 SET INARRAY(13)="Veteran Care in the Community"
+33 ;The space is needed after N/A to pass four character requirement
+34 ;in XUESSO2.
+35 SET INARRAY(14)="N/A "
+36 ;
+37 ;The additional check for production ensures that duplicate errors won't
+38 ;be generated during testing.
+39 IF PSOPROD
IF $$PROD^XUPROD=1
SET PSONEW=$$VACAA^XUESSO4(.INARRAY,AUTHCODE)
+40 ;
+41 ;If PSONEW is less than 1, XUESSO4 refused to file, so there is no need
+42 ;to continue attempting to file additional data for this provider.
+43 IF +PSONEW<1
DO PROB
QUIT
+44 DO NPI(+PSONEW,INARRAY(10))
DO MORE
DO DEL
+45 QUIT
+46 ;
PROB ;problem detected after FileMan call
+1 NEW PSOXERR,PSOTXT,PSOPAD
+2 SET PSOXE=PSOXE+1
+3 SET PSOTXT=$SELECT($PIECE(PSONEW,U,2)]"":$PIECE(PSONEW,U,2),1:"No reason text available.")
+4 IF PSOFLG=1
SET PSOTXT="Check ^XTMP(""PSONONVA ""_[job number],[date],""PROBLEM"""
+5 SET PSOPAD=$EXTRACT(" ",1,55-$LENGTH(PSOTXT))
+6 SET ^XTMP(PSOJOB,PSODT,"PROBLEM",PSOTM,PSOXE)=$EXTRACT(PSOTXT,1,55)_PSOPAD_$EXTRACT(INARRAY(1),1,20)
+7 MERGE ^XTMP(PSOJOB,PSODT,"PROBLEM",PSOTM,PSOXE)=INARRAY
+8 IF PSOFLG=1
Begin DoDot:1
+9 MERGE ^XTMP(PSOJOB,PSODT,"PROBLEM",PSOTM,PSOXE)=PSOERR
End DoDot:1
+10 QUIT
+11 ;
NPI(PSODUZ2,PSONPI2) ;This call needed to file EFFECTIVE DATE/TIME and sub-fields
+1 NEW PSOCHK
+2 SET PSOCHK=$$ADDNPI^XUSNPI("Individual_ID",+PSODUZ2,PSONPI2,$$NOW^XLFDT(),1)
+3 QUIT
+4 ;
MORE ;File additional fields
+1 ;approved by IA #6889
+2 NEW PSOFDR,PSOERR,X,Y
+3 ;
+4 ;PSOFLG is used in PROB if there are FileMan errors
+5 SET PSOFLG=1
+6 ;
+7 ;Service/Section
+8 SET PSOFDR(200,+PSONEW_",",29)=PSOSERV
+9 ;
+10 ;Remarks
+11 SET PSOFDR(200,+PSONEW_",",53.9)=$PIECE(PSOTMP2,",",6)_" NON-VA PROVIDER"
+12 ;DEA Expiration Date (convert to VistA date format if not null)
+13 SET X=$PIECE(PSOTMP2,",",8)
+14 IF X]""
Begin DoDot:1
+15 DO ^%DT
+16 SET PSOFDR(200,+PSONEW_",",747.44)=Y
End DoDot:1
+17 ;Detox/Maintenance ID Number
+18 SET PSOFDR(200,+PSONEW_",",53.11)=$PIECE(PSOTMP2,",",9)
+19 ;
+20 ;Convert "Y" or "N" for Schedule fields to "1" or "0"
+21 ;Schedule II Narcotic
+22 SET PSOFDR(200,+PSONEW_",",55.1)=$SELECT($PIECE(PSOTMP2,",",10)="Y":1,1:0)
+23 ;Schedule II Non-Narcotic
+24 SET PSOFDR(200,+PSONEW_",",55.2)=$SELECT($PIECE(PSOTMP2,",",11)="Y":1,1:0)
+25 ;Schedule III Narcotic
+26 SET PSOFDR(200,+PSONEW_",",55.3)=$SELECT($PIECE(PSOTMP2,",",12)="Y":1,1:0)
+27 ;Schedule III Non-Narcotic
+28 SET PSOFDR(200,+PSONEW_",",55.4)=$SELECT($PIECE(PSOTMP2,",",13)="Y":1,1:0)
+29 ;Schedule IV
+30 SET PSOFDR(200,+PSONEW_",",55.5)=$SELECT($PIECE(PSOTMP2,",",14)="Y":1,1:0)
+31 ;Schedule V
+32 SET PSOFDR(200,+PSONEW_",",55.6)=$SELECT($PIECE(PSOTMP2,",",15)="Y":1,1:0)
+33 DO UPDATE^DIE("","PSOFDR","IEN","PSOERR")
+34 IF $DATA(PSOERR("DIERR"))
DO PROB
+35 ;
+36 ;continue filing additional fields even if there was a problem
+37 ;with previous call since the provider has information filed by this time.
+38 ;
+39 KILL PSOFDR,PSOERR
+40 SET PSOFDR(200,+PSONEW_",",8)=$PIECE(PSOTMP2,",",6)_" NON-VA PROVIDER"
+41 DO UPDATE^DIE("E","PSOFDR","IEN","PSOERR")
+42 IF $DATA(PSOERR("DIERR"))
DO PROB
+43 ;
+44 ;if Title is not defined in the TITLE (#3.1) file, file as text
+45 KILL PSOERR
+46 IF $PIECE($GET(^VA(200,+PSONEW,0)),"^",9)=""
Begin DoDot:1
+47 DO UPDATE^DIE("U","PSOFDR","IEN","PSOERR")
+48 IF $DATA(PSOERR("DIERR"))
DO PROB
End DoDot:1
+49 SET PSOXF=PSOXF+1
+50 SET ^XTMP(PSOJOB,PSOTM,"NPI",INARRAY(10))=""
+51 SET ^XTMP(PSOJOB,PSODT,"SUCCESS",PSOTM,PSOXF)=+PSONEW_$EXTRACT(" ",1,15-$LENGTH(+PSONEW))_$EXTRACT(INARRAY(1),1,35)
+52 KILL INARRAY
+53 ;
+54 QUIT
+55 ;
DEL ;Delete key XUORES which was filed by XUESSO4
+1 ;UNCOMMENT if it is decided later to remove the key
+2 ;N DIC,X,DIK,DA
+3 ;S DIK="^VA(200,"_+PSONEW_",51,"
+4 ;S DA(1)=+PSONEW
+5 ;S DIC="^DIC(19.1,",DIC(0)="MZ",X="XUORES" D ^DIC
+6 ;S DA=+Y
+7 ;D ^DIK
+8 QUIT
+9 ;
FNDUSR(PSONPI) ;see if provider already on file
+1 ;A previous version of this routine checked to see if the
+2 ;provider is active. However, if the NPI is already on file,
+3 ;Kernel routine XUESSO4 will file data into the New Person IEN
+4 ;on file. This can create issues because old and new information
+5 ;is on file within the same IEN.
+6 NEW PSOATTRIB
+7 ; NPI
SET PSOATTRIB(8)=PSONPI
+8 SET PSODUZ=$$QI^XUSNPI(PSOATTRIB(8))
+9 QUIT $SELECT(PSODUZ'=0:1,1:0)
+10 ;
CHKNAME() ;is provider name already in New Person file
+1 ;if so, store data in trace global and send MailMan message
+2 NEW PSONAME
+3 ;do not validate suffix to be on safe side
+4 SET PSONAME=$PIECE(PSOTMP1,",",1,2)
+5 IF $DATA(^VA(200,"B",PSONAME))
QUIT 1
+6 QUIT 0
+7 ;
END ;clean up
+1 ;
+2 KILL ^XTMP(PSOJOB,PSOTM)
+3 KILL ^XTMP(PSOJOB,PSODT,"ZNPI")
+4 KILL ^XTMP(PSOFILE,PSOTM)
+5 KILL PSODIR,PSOFILE,PSOSAVDUZ,PSOTM
+6 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
+8 ;
