Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSONVAP2

PSONVAP2.m

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