VAFCPTAD ;ISA/RJS,ZOLTAN - Add an entry to the PATIENT (#2) file; 26-Apr-2023 4:26 PM
;;5.3;Registration;**149,800,876,944,950,955,1033,1042,1050,1099,1131**;Aug 13, 1993;Build 4
;
ADD(RETURN,PARAM) ;Entry point for VAFC VOA ADD PATIENT remote procedure
;Input PARAM array = List of data to be used for the creation of a VistA PATIENT (#2) record at the Preferred Facility.
;Required elements include:
; PARAM("PRFCLTY")=PREFERRED FACILITY
; PARAM("NAME")=NAME (last name minimal; recommend full name), 30 chars max
; PARAM("GENDER")=SEX PARAM("DOB")=DATE OF BIRTH
; PARAM("SSN")=SOCIAL SECURITY NUMBER OR NULL IF NONE and want a psuedo SSN created
; PARAM("SRVCNCTD")=SERVICE CONNECTED? PARAM("TYPE")=Patient TYPE
; PARAM("VET")=VETERAN (Y/N)? PARAM("FULLICN")=INTEGRATION CONTROL NUMBER with CHECKSUM
;Optional elements include:
; PARAM("LONGNAME")=NAME (set if full name is greater than 30 chars) ;**1050,VAMPI-9503 (mko): New input, allows setting Name Components to long name
; PARAM("POBCTY")=PLACE OF BIRTH [CITY] PARAM("POBST")=PLACE OF BIRTH [STATE]
; PARAM("MMN")=MOTHER'S MAIDEN NAME PARAM("MBI")=MULTIPLE BIRTH INDICATOR
; PARAM("ALIAS",#)=ALIAS NAME(last^first^middle^suffix)^ALIAS SSN
; **1033 enrollment, address and phone
; PARAM("ENROLLMENT")=1 if would like the ES messaging triggered
; PARAM("ResAddL1")=Resident Street Address line 1 ;PARAM("ResAddL2")=Resident Street Address line 2
; PARAM("ResAddL3")=Resident Street Address line 3 ;PARAM("ResAddCity")=Resident City
; PARAM("ResAddState")=Resident State ;PARAM("ResAddZIP")=Resident Zip
; PARAM("ResPhone")=Home Phone Number ;PARAM("ResAddCountry")=COUNTRY FOR FORIEGN ADDRESS
; PARAM("ResAddPCode")=POSTAL CODE FOR FORIEGN ADDRESS ;PARAM("ResAddProvince")=PROVINCE FOR FORIEGN ADDRESS
;Output:
; On Failure: -1^error text - record add failed
; On Success: 1^DFN of new PATIENT (#2) record
;
EN1 ;Check value of all required fields
K RETURN D NOW^%DTC
N ALSERR,DIERR,DPTIDS,DPTX,ERROR,FLG,FDA,FN,LN,MN,RESULT,RGRSICN,SFX,VAL,VAFCA08,X,Y,UPDNC,VAFCDFN,VAFCDOB,VAFCICN,VAFCMMN,VAFCNAM,VAFCPF,VAFCPOBC,VAFCPOBS
N VAFCRSN,VAFCSRV,VAFCSSN,VAFCSUM,VAFCSX,VAFCTYP,VAFCVET,VAFCMBI,VAFCPN,VAFCPR,VAFCPC,VAFCPCT,VAFCAL1,VAFCAL2,VAFCAL3,VAFCACY,VAFCAST,VAFCAZ,VAFCACTY,CNTY
N VAFCSEQ S VAFCSEQ=$$RECORD(.PARAM)
S (RGRSICN,VAFCA08)=1 S FLG=0 ;allow update to ICN; prevent triggering of messages
;PREFERRED FACILITY
I $G(PARAM("PRFCLTY"))="" S RETURN(1)="-1^PREFERRED FACILITY is a required field." G END
;**955 (cmc) Story 699475 don't require perferred facility to be this site if this is station 200
;**1131 (cmc) VAMPI-26434 allow 741MM to be a perferred facility
I $P($$SITE^VASITE(),"^",3)'=200&(PARAM("PRFCLTY")'="741MM") I $G(PARAM("PRFCLTY"))'=$P($$SITE^VASITE(),"^",3) S RETURN(1)="-1^PREFERRED FACILITY is not the station to which the RPC was sent." G END
I $G(PARAM("PRFCLTY"))'=""&(PARAM("PRFCLTY")'="741MM") S VAL=$G(PARAM("PRFCLTY")) D CHK^DIE(2,27.02,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
I $G(PARAM("PRFCLTY"))'="" S VAL=$G(PARAM("PRFCLTY"))
S VAFCPF=VAL,FLG=1
;
;INTEGRATION CONTROL NUMBER and ICN CHECKSUM
I $G(PARAM("FULLICN"))=""!($G(PARAM("FULLICN"))'["V") S RETURN(1)="-1^Full INTEGRATION CONTROL NUMBER with ICN CHECKSUM is required." G END
I $G(PARAM("FULLICN"))'="" S PARAM("ICN")=$P(PARAM("FULLICN"),"V"),PARAM("CHKSUM")=$P(PARAM("FULLICN"),"V",2)
I $G(PARAM("ICN"))'="" S VAL=$G(PARAM("ICN")) D CHK^DIE(2,991.01,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
S VAFCICN=VAL,FLG=1
I $G(PARAM("CHKSUM"))'="" S VAL=$G(PARAM("CHKSUM")) D CHK^DIE(2,991.02,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
S VAFCSUM=VAL,FLG=1
;Has patient already been created at this facility? If so get DFN and quit.
S VAFCDFN=+$O(^DPT("AICN",PARAM("ICN"),0))
I VAFCDFN D G:$D(RETURN(1)) END
.;**1050,VAMPI-9503 (mko): Make sure the 0 node of the patient exists before quitting with the DFN.
.; If not, kill the erroneous "AICN" index entry and continue
.I $D(^DPT(VAFCDFN,0))[0 K ^DPT("AICN",PARAM("ICN"),VAFCDFN),VAFCDFN Q
.S RETURN(1)="1^"_$O(^DPT("AICN",PARAM("ICN"),0))_$S($$GETFLAG^VAFCPTED:"^^1",1:"")
;
;NAME INPUT AS:LAST^FIRST^MIDDLE^SUFFIX; MUST BE FORMATTED FOR VISTA INPUT
;**1099,VAMPI-19828 (mko): Build VistA name in VAFCNAM instead of PARAM("NAME")
I $G(PARAM("NAME"))="" S RETURN(1)="-1^Patient NAME is a required field." G END
S LN=$P($G(PARAM("NAME")),"^"),FN=$P($G(PARAM("NAME")),"^",2),MN=$P($G(PARAM("NAME")),"^",3),SFX=$P($G(PARAM("NAME")),"^",4)
S VAFCNAM=LN_","
S:FN'="" VAFCNAM=VAFCNAM_FN
S:MN'="" VAFCNAM=VAFCNAM_" "_MN
S:SFX'="" VAFCNAM=VAFCNAM_" "_SFX
D CHK^DIE(2,.01,,VAFCNAM,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
S FLG=1,DPTX=VAFCNAM ;variable used by SSN input transform
;
;DATE OF BIRTH
I $G(PARAM("DOB"))="" S RETURN(1)="-1^DATE OF BIRTH is a required field." G END
I $G(PARAM("DOB"))'="" S VAL=$G(PARAM("DOB")) D CHK^DIE(2,.03,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
S VAFCDOB=VAL,FLG=1,DPTIDS(.03)=RESULT ;variable used by PSEUDO-SSN code
;
;SOCIAL SECURITY NUMBER not equal null; valid 9-digit number
I '$D(PARAM("SSN")) S RETURN(1)="-1^SOCIAL SECURITY NUMBER is a required field. A null value may be sent." G END
I $G(PARAM("SSN"))'="" S VAL=$G(PARAM("SSN")) D CHK^DIE(2,.09,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
I $G(PARAM("SSN"))'="" S VAFCSSN=VAL,FLG=1
I $G(PARAM("SSN"))="" D ;SSN null, set PSEUDO SSN REASON=SSN UNKNOWN/FOLLOW-UP
.S PARAM("SSN")="P" ;PSEUDO SSN
.S PARAM("PSEUDO")="S" ;PSEUDO SSN REASON
.S VAFCSSN=$G(PARAM("SSN")),FLG=1
.;If SSN null, set PSEUDO SSN REASON (#.0906) =SSN UNKNOWN/FOLLOW-UP
.S VAFCRSN=$G(PARAM("PSEUDO")),FLG=1
;
;SEX
I $G(PARAM("GENDER"))="" S RETURN(1)="-1^GENDER is a required field." G END
I $G(PARAM("GENDER"))'="" S VAL=$G(PARAM("GENDER")) D CHK^DIE(2,.02,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
S VAFCSX=VAL,FLG=1
;
;SERVICE CONNECTED?
I $G(PARAM("SRVCNCTD"))="" S RETURN(1)="-1^'SERVICE CONNECTED?' is a required field." G END
;input set to either YES or NO on the MPI before RPC call; skip CHK^DIE here as it resulted in error; expected DFN variable which is not yet set.
I $G(PARAM("SRVCNCTD"))'="" S VAFCSRV=$G(PARAM("SRVCNCTD"))
;
;TYPE
I $G(PARAM("TYPE"))="" S RETURN(1)="-1^Patient TYPE is a required field." G END
I $G(PARAM("TYPE"))'="" S VAL=$G(PARAM("TYPE")) D CHK^DIE(2,391,,VAL,.RESULT) I RESULT="^" S RETURN(1)="-1^"_^TMP("DIERR",$J,1,"TEXT",1) G END
S VAFCTYP=VAL,FLG=1
;
;VETERAN Y/N?
I $G(PARAM("VET"))="" S RETURN(1)="-1^'VETERAN Y/N?' is a required field." G END
;input set to either YES or NO on the MPI before RPC call; skip CHK^DIE here as it resulted in error; expected DFN variable which is not yet set.
I $G(PARAM("VET"))'="" S VAFCVET=$E($G(PARAM("VET")),1),FLG=1 ;internal format
;
;Optional - POB CITY
I $D(PARAM("POBCTY")) S VAL=$G(PARAM("POBCTY")) D CHK^DIE(2,.092,,VAL,.RESULT) I RESULT="^" S PARAM("POBCTY")=""
I $G(PARAM("POBCTY"))'="" S VAFCPOBC=VAL,FLG=1
;
;Optional - POB STATE
N STIEN,UNDEF S UNDEF=0
I $D(PARAM("POBST")) D I UNDEF S PARAM("POBST")=""
.;Convert STATE ABBREVIATION into STATE NAME
.S STIEN=$O(^DIC(5,"C",PARAM("POBST"),0))
.I STIEN="" S UNDEF=1 Q
.I STIEN'="" S PARAM("POBST")=$P($G(^DIC(5,STIEN,0)),"^")
.S VAL=$G(PARAM("POBST")) D CHK^DIE(2,.093,,VAL,.RESULT) I RESULT="^" S UNDEF=1 Q
I $G(PARAM("POBST"))'="" S VAFCPOBS=VAL,FLG=1
;
;Optional - MOTHER'S MAIDEN NAME RESET TO NULL IF INVALID VALUE TO ALLOW ADD TO CONTINUE **1033
I $D(PARAM("MMN")) S VAL=$G(PARAM("MMN")) D CHK^DIE(2,.2403,,VAL,.RESULT) I RESULT="^" S PARAM("MMN")=""
I $G(PARAM("MMN"))'="" S VAFCMMN=VAL,FLG=1
;
;**876 - MVI_2788 (ckn) - Add MBI
;Optional - MULTIPLE BIRTH INDICATOR RESET TO NULL IF INVALID VALUE TO ALLOW ADD TO CONTINUE **1033
I $D(PARAM("MBI")) S VAL=$G(PARAM("MBI")) D CHK^DIE(2,994,,VAL,.RESULT) I RESULT="^" S PARAM("MBI")=""
I $G(PARAM("MBI"))'="" S VAFCMBI=VAL,FLG=1
;
;**1013 OPTIONAL ADDRESS FIELDS AND PHONE RESET TO NULL IF INVALID VALUE TO ALLOW ADD TO CONTINUE **1033
I $D(PARAM("ResAddL1")) S VAL=$G(PARAM("ResAddL1")) D CHK^DIE(2,.111,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddL1")=""
;ONLY GET LINE2+ IF THE LINE BEFORE WAS GOOD
I $G(PARAM("ResAddL1"))'="" S VAFCAL1=VAL,FLG=1 I $D(PARAM("ResAddL2")) S VAL=$G(PARAM("ResAddL2")) D CHK^DIE(2,.112,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddL2")=""
I $G(PARAM("ResAddL2"))'="" S VAFCAL2=VAL,FLG=1 I $D(PARAM("ResAddL3")) S VAL=$G(PARAM("ResAddL3")) D CHK^DIE(2,.113,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddL3")=""
I $G(PARAM("ResAddL3"))'="" S VAFCAL3=VAL,FLG=1
I $D(PARAM("ResAddCity")) S VAL=$G(PARAM("ResAddCity")) D CHK^DIE(2,.114,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddCity")=""
I $G(PARAM("ResAddCity"))'="" S VAFCACY=VAL,FLG=1
I $G(PARAM("ResAddState"))'="" D I UNDEF S PARAM("ResAddState")=""
.;Convert STATE ABBREVIATION into STATE NAME
.S STIEN=$O(^DIC(5,"C",PARAM("ResAddState"),0))
.I STIEN="" S UNDEF=1 Q
.I STIEN'="" S PARAM("ResAddState")=$P($G(^DIC(5,STIEN,0)),"^")
.S VAL=$G(PARAM("ResAddState")) D CHK^DIE(2,.115,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddState")=""
I $G(PARAM("ResAddState"))'="" S VAFCAST=VAL,FLG=1
I $D(PARAM("ResAddZIP")) S VAL=$G(PARAM("ResAddZIP")) D CHK^DIE(2,.1112,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddZIP")=""
I $G(PARAM("ResAddZIP"))'="" S VAFCAZ=VAL,FLG=1
;**1042,VAMPI-8199 (mko): Get County from Zip Code.
; State must have a value, as dictated by the input transform of the COUNTY field (#.117) of the PATIENT file (#2).
; Value to be filed is the subien of the county in the state file
I $G(VAFCAZ)]"",$G(VAFCAST)]"" D
.N ARR
.D POSTAL^XIPUTIL(VAFCAZ,.ARR) Q:$G(ARR("COUNTY"))=""
.S VAL=$O(^DIC(5,+$G(STIEN),1,"B",ARR("COUNTY"),0))
.S:VAL>0 VAFCACTY=VAL
I $D(PARAM("ResPhone")) S VAL=$G(PARAM("ResPhone")) D CHK^DIE(2,.131,,VAL,.RESULT) I RESULT="^" S PARAM("ResPhone")=""
I $G(PARAM("ResPhone"))'="" S VAFCPN=VAL,FLG=1
I $G(PARAM("ResAddProvince"))'="" S VAL=$G(PARAM("ResAddProvince")) D CHK^DIE(2,.1171,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddProvince")=""
I $G(PARAM("ResAddProvince"))'="" S VAFCPR=VAL,FLG=1
;**1050,VAMPI-9503 (mko): Remove initial I $G(PARAM("ResAddProvince"))'="" test -- don't require a valid Province be sent for Postal Code to be checked
I $G(PARAM("ResAddPCode"))'="" S VAL=$G(PARAM("ResAddPCode")) D CHK^DIE(2,.1172,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddPCode")=""
I $G(PARAM("ResAddPCode"))'="" S VAFCPC=VAL,FLG=1
;**1050,VAMPI-9503 (mko): Remove initial I $G(PARAM("ResAddProvince"))'="" test -- don't require a valid Province be sent for Country to be checked
I $G(PARAM("ResAddCountry"))'="" D
.;convert Country Abbreviation into Country DESCRIPTION
.S CNTY=$O(^HL(779.004,"B",$G(PARAM("ResAddCountry")),""))
.I CNTY="" S PARAM("ResAddCountry")=""
.I CNTY'="" S VAL=PARAM("ResAddCountry") D CHK^DIE(2,.1173,,VAL,.RESULT) I RESULT="^" S PARAM("ResAddCountry")=""
I $G(PARAM("ResAddCountry"))'="" S VAFCPCT=PARAM("ResAddCountry"),FLG=1
;
I FLG=0 S RETURN(1)="-1^Required information is missing; please check input and try again." G END
;Else ok to file entry
FILE ;Call FILE^DICN to add new entry to PATIENT (#2) file
N DA,DIC,DR,FULLICN K DD,DO,VAFCRSLT
S DIC="^DPT(",DIC(0)="FLZ",DLAYGO=2,X=VAFCNAM
;**876 MVI_2788 (ckn) - Remove four slash use for field 1901
;**944 Story #557843 (cml) add code to update FULL ICN (#991.1), WHO ENTERED PATIENT (#.096), and DATE ENTERED INTO FILE (#.097) fields
S FULLICN=VAFCICN_"V"_VAFCSUM
S DIC("DR")=".09///"_VAFCSSN_";.03///"_VAFCDOB_";.02///"_VAFCSX_";391///"_VAFCTYP_";1901///"_VAFCVET_";.301///"_VAFCSRV_";991.01///"_VAFCICN_";991.02///"_VAFCSUM_";991.1///"_FULLICN
I VAFCSSN="P" S DIC("DR")=DIC("DR")_";.0906///"_VAFCRSN
;
;**1050,VAMPI-9503 (mko): Separate single FILE^DICN call into one FILE^DICN call to add the record with required fields
; and a subsequent FILE^DIE call to update the optional fields
L +^DPT(0):10
D FILE^DICN K DA,DIC,DD,DLAYGO,DO,DR
L -^DPT(0)
;If record creation/update fails, return a -1^error text
I $P(Y,U,3)'=1 S RETURN(1)="-1^"_"Attempt to add patient "_VAFCNAM_" to the PATIENT (#2) file at station number "_$P($$SITE^VASITE,"^",3)_" failed." G END
S VAFCDFN=+Y
;
;**1050,VAMPI-9503 (mko): After record is created, call FILE^DIE to update the record
D
.N DIERR,DIMSG,DIHELP,FDA,IENS,MSG
.S IENS=VAFCDFN_","
.S:$G(VAFCPOBC)]"" FDA(2,IENS,.092)=VAFCPOBC ;POB CITY
.S:$G(VAFCPOBS)]"" FDA(2,IENS,.093)=VAFCPOBS ;POB STATE
.S:$G(VAFCMMN)]"" FDA(2,IENS,.2403)=VAFCMMN ;MMN
.;**876 - MVI_2788 (ckn)
.S:$G(VAFCMBI)]"" FDA(2,IENS,994)=VAFCMBI ;MBI
.;**1033 ADDING ADDRESS FIELDS
.S:$G(VAFCAL1)]"" FDA(2,IENS,.111)=VAFCAL1 ;STREET LINE 1
.S:$G(VAFCAL2)]"" FDA(2,IENS,.112)=VAFCAL2 ;STREET LINE 2
.S:$G(VAFCAL3)]"" FDA(2,IENS,.113)=VAFCAL3 ;STREET LINE 3
.S:$G(VAFCACY)]"" FDA(2,IENS,.114)=VAFCACY ;CITY
.S:$G(VAFCAST)]"" FDA(2,IENS,.115)=VAFCAST ;STATE
.S:$G(VAFCAZ)]"" FDA(2,IENS,.1112)=VAFCAZ ;ZIP
.S:$G(VAFCPN)]"" FDA(2,IENS,.131)=VAFCPN ;PHONE NUMBER
.S:$G(VAFCPR)]"" FDA(2,IENS,.1171)=VAFCPR ;PROVINCE
.S:$G(VAFCPC)]"" FDA(2,IENS,.1172)=VAFCPC ;POSTAL CODE
.S:$G(VAFCPCT)]"" FDA(2,IENS,.1173)=VAFCPCT ;COUNTRY
.Q:'$D(FDA)
.L +^DPT(VAFCDFN):10 E Q
.D FILE^DIE("E","FDA","MSG") L -^DPT(VAFCDFN)
;
;**1042,VAMPI-8199 (mko): File County (determined from Zip); Need to use 4-slash stuff because IT is interative
; when county name matches more than one entry (e.g., BALTIMORE and BALTIMORE (CITY)
;**1050,VAMPI-9503 (mko): Use FILE^DIE to file county instead of FILE^DICN
D:$G(VAFCACTY)]""
.N DIERR,DIMSG,DIHELP,FDA,MSG
.S FDA(2,VAFCDFN_",",.117)=VAFCACTY ;COUNTY
.L +^DPT(VAFCDFN):10 E Q
.D FILE^DIE("","FDA","MSG") L -^DPT(VAFCDFN)
;
;**1050,VAMPI-9503 (mko): If NC flag is set, file the name components
K UPDNC I $$GETFLAG^VAFCPTED S UPDNC=$$UPDNC(VAFCDFN,$G(PARAM("LONGNAME"),$G(PARAM("NAME"))))
;
;**1033 VAMPI-12 (jfw) - Interfacility Consult (IFC) support
; Trigger enrollment/eligibility HL7 messaging to further update patient info
S:($G(PARAM("ENROLLMENT"))=1) VAFCRSLT=$$QRY^DGENQRY(VAFCDFN)
; file Who and When if not already done
N DGZ,FDA
S DGZ=$G(^DPT(VAFCDFN,0))
S:'$P(DGZ,"^",15) FDA(2,VAFCDFN_",",.096)=DUZ
S:'$P(DGZ,"^",16) FDA(2,VAFCDFN_",",.097)=DT
D:$D(FDA) FILE^DIE("","FDA")
;
;File ALIAS multiple
I $D(PARAM("ALIAS")) D ALIAS ;If ALIAS data is passed, call ALIAS module
I $G(ALSERR)="" S RETURN(1)="1^"_VAFCDFN ;No errors for ALIAS, return DFN
I $G(ALSERR)'="" S RETURN(1)=ALSERR
;
;**1050,VAMPI-9503 (mko): If the components of the name were filed, return 4th piece equal to 1
S:$G(UPDNC) $P(RETURN(1),U,4)=1
;
END ;**1050,VAMPI-9503 (mko): Record return value and quit
D RETURN(VAFCSEQ,.RETURN)
Q
;
ALIAS ;Optional - Add ALIAS and ALIAS SSN data for entry
;Only occurs for a NEW record; there is no previous ALIAS data
I '$D(PARAM("ALIAS")) Q
;ALIAS input comes in as: LAST^FIRST^MIDDLE^SUFFIX^SSN
N AFN,ALN,AMN,ASFX,ASSN,ERR,FDA,I,LOC,NUM
S (I,NUM)=0 F S NUM=$O(PARAM("ALIAS",NUM)) Q:'NUM D
.S ALN=$P($G(PARAM("ALIAS",NUM)),"^") Q:ALN="" ;Last name minimal input
.S AFN=$P($G(PARAM("ALIAS",NUM)),"^",2),AMN=$P($G(PARAM("ALIAS",NUM)),"^",3)
.S ASFX=$P($G(PARAM("ALIAS",NUM)),"^",4),ASSN=$P($G(PARAM("ALIAS",NUM)),"^",5)
.;Change format for VistA input: LAST,FIRST MIDDLE SUFFIX^SSN
.S LOC(NUM)=ALN_","
.I AFN'="" S LOC(NUM)=LOC(NUM)_AFN
.I AMN'="" S LOC(NUM)=LOC(NUM)_" "_AMN
.I ASFX'="" S LOC(NUM)=LOC(NUM)_" "_ASFX
.S LOC(NUM)=LOC(NUM)_"^"
.I ASSN'="" S LOC(NUM)=LOC(NUM)_ASSN
.;Set FDA nodes
.S I=I+1 ;Unique sequence number for add to ALIAS SUB-FILE (#2.01
.S FDA(2.01,"+"_I_","_VAFCDFN_",",.01)=$P(LOC(NUM),"^") ; (#.01) ALIAS (name)
.I ASSN'="" S FDA(2.01,"+"_I_","_VAFCDFN_",",1)=$P(LOC(NUM),"^",2) ; (#1) ALIAS SSN
;Update ALIAS multiple with new entries
I $D(FDA) D ;We have ALIAS data to add
.S ALSERR=""
.L +^DPT(VAFCDFN):10 D UPDATE^DIE("E","FDA",,"ERR") L -^DPT(VAFCDFN)
.I $D(ERR("DIERR")) S ALSERR="1^"_VAFCDFN_"^Patient "_PARAM("NAME")_" was successfully added at "_$P($$SITE^VASITE,"^",3)_". However, the ALIAS data failed to update. Error message: "_$G(ERR("DIERR","1","TEXT",1)) Q
Q
;
UPDNC(VAFCDFN,NAME) ;Update name components; Return 1 if updated
;**1050,VAMPI-9503 (mko): New subroutine
N CURR,DIERR,DIMSG,DIHELP,FDA,MSG,NCIENS
Q:$G(NAME)?."^" 0
Q:$G(VAFCDFN)'>0 0
S NCIENS=$P($G(^DPT(+VAFCDFN,"NAME")),U)_"," Q:'NCIENS 0
;
;Get current values
D GETS^DIQ(20,NCIENS,"1;2;3;5","","CURR","MSG") Q:$G(DIERR) 0
;
;**1099,VAMPI-19828 (mko): Quit 0 if there are no differences
S CURR("NAME")=CURR(20,NCIENS,1)_U_CURR(20,NCIENS,2)_U_CURR(20,NCIENS,3)_U_CURR(20,NCIENS,5)_U
S $P(NAME,U,5)=""
Q:CURR("NAME")=NAME 0
;
;**1099,VAMPI-19828 (mko): Set FDA for each component even if not different from current
; so that FILE^DIE can check that all are valid before any are filed.
S FDA(20,NCIENS,1)=$P(NAME,U)
S FDA(20,NCIENS,2)=$P(NAME,U,2)
S FDA(20,NCIENS,3)=$P(NAME,U,3)
S FDA(20,NCIENS,5)=$P(NAME,U,4)
;
;Call Filer
D FILE^DIE("EKT","FDA","MSG")
Q '$G(DIERR)
;
;=================================================
; Code for storing debugging information in ^XTMP
;=================================================
RECORD(PARAM,RPCNAME) ;Record RPC inputs for debugging
;Return seq# in ^XTMP
N NODE,NOW,SEQ,TODAY
Q:'$$ISDEBUG 0
S:$G(RPCNAME)="" RPCNAME="VAFC VOA ADD PATIENT"
S NOW=$$NOW^XLFDT,TODAY=$P(NOW,".")
S NODE=$$NODE
;
L +^XTMP(NODE):2
D SETXTMP0(NODE)
S SEQ=$O(^XTMP(NODE," "),-1)+1
M ^XTMP(NODE,SEQ,"PARAM")=PARAM
S ^XTMP(NODE,SEQ,"DT")=NOW
S ^XTMP(NODE,SEQ,"DUZ")=$G(DUZ)
S ^XTMP(NODE,SEQ,"RPC")=RPCNAME
L -^XTMP(NODE)
Q SEQ
;
RETURN(SEQ,RETURN) ;Record the return value
Q:'SEQ Q:'$$ISDEBUG
M ^XTMP($$NODE,SEQ,"RETURN")=RETURN
Q
;
DBON ;Set DEBUG on
N NODE
S NODE=$$NODE
D SETXTMP0
S ^XTMP(NODE,"DEBUG")=1
W !,$NA(^XTMP(NODE,"DEBUG"))_" set to 1.",!
Q
;
DBOFF ;Set DEBUG off
N NODE
S NODE=$$NODE
K ^XTMP(NODE,"DEBUG")
K:'$O(^XTMP(NODE,0)) ^XTMP(NODE)
W !,$NA(^XTMP(NODE,"DEBUG"))_" killed.",!
Q
;
ISDEBUG() ;Return 1 if DEBUG mode flag is set
Q $G(^XTMP($$NODE,"DEBUG"))
;
PURGE ;Purge the debugging data stored in ^XTMP
N ISDEBUG
S ISDEBUG=$$ISDEBUG
K ^XTMP($$NODE)
W !,$NA(^XTMP($$NODE))_" killed.",!
D:ISDEBUG DBON
Q
;
SETXTMP0(NODE,DESC,LIFE) ;Set 0 node of ^XTMP(node)
N CREATEDT
S:$G(NODE)="" NODE=$$NODE
S CREATEDT=$S($D(^XTMP(NODE,0))#2:$P(^(0),U,2),1:DT)
S:'$G(LIFE) LIFE=30
S:$G(DESC)="" DESC="Inputs and Outputs to RPC: VAFC VOA ADD PATIENT"
S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,LIFE)_U_CREATEDT_U_DESC
Q
;
NODE() ;Return ^XTMP Debug subscript
Q "VAFC_VOA_ADD_PATIENT"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCPTAD 19340 printed Sep 23, 2025@20:38:05 Page 2
VAFCPTAD ;ISA/RJS,ZOLTAN - Add an entry to the PATIENT (#2) file; 26-Apr-2023 4:26 PM
+1 ;;5.3;Registration;**149,800,876,944,950,955,1033,1042,1050,1099,1131**;Aug 13, 1993;Build 4
+2 ;
ADD(RETURN,PARAM) ;Entry point for VAFC VOA ADD PATIENT remote procedure
+1 ;Input PARAM array = List of data to be used for the creation of a VistA PATIENT (#2) record at the Preferred Facility.
+2 ;Required elements include:
+3 ; PARAM("PRFCLTY")=PREFERRED FACILITY
+4 ; PARAM("NAME")=NAME (last name minimal; recommend full name), 30 chars max
+5 ; PARAM("GENDER")=SEX PARAM("DOB")=DATE OF BIRTH
+6 ; PARAM("SSN")=SOCIAL SECURITY NUMBER OR NULL IF NONE and want a psuedo SSN created
+7 ; PARAM("SRVCNCTD")=SERVICE CONNECTED? PARAM("TYPE")=Patient TYPE
+8 ; PARAM("VET")=VETERAN (Y/N)? PARAM("FULLICN")=INTEGRATION CONTROL NUMBER with CHECKSUM
+9 ;Optional elements include:
+10 ; PARAM("LONGNAME")=NAME (set if full name is greater than 30 chars) ;**1050,VAMPI-9503 (mko): New input, allows setting Name Components to long name
+11 ; PARAM("POBCTY")=PLACE OF BIRTH [CITY] PARAM("POBST")=PLACE OF BIRTH [STATE]
+12 ; PARAM("MMN")=MOTHER'S MAIDEN NAME PARAM("MBI")=MULTIPLE BIRTH INDICATOR
+13 ; PARAM("ALIAS",#)=ALIAS NAME(last^first^middle^suffix)^ALIAS SSN
+14 ; **1033 enrollment, address and phone
+15 ; PARAM("ENROLLMENT")=1 if would like the ES messaging triggered
+16 ; PARAM("ResAddL1")=Resident Street Address line 1 ;PARAM("ResAddL2")=Resident Street Address line 2
+17 ; PARAM("ResAddL3")=Resident Street Address line 3 ;PARAM("ResAddCity")=Resident City
+18 ; PARAM("ResAddState")=Resident State ;PARAM("ResAddZIP")=Resident Zip
+19 ; PARAM("ResPhone")=Home Phone Number ;PARAM("ResAddCountry")=COUNTRY FOR FORIEGN ADDRESS
+20 ; PARAM("ResAddPCode")=POSTAL CODE FOR FORIEGN ADDRESS ;PARAM("ResAddProvince")=PROVINCE FOR FORIEGN ADDRESS
+21 ;Output:
+22 ; On Failure: -1^error text - record add failed
+23 ; On Success: 1^DFN of new PATIENT (#2) record
+24 ;
EN1 ;Check value of all required fields
+1 KILL RETURN
DO NOW^%DTC
+2 NEW ALSERR,DIERR,DPTIDS,DPTX,ERROR,FLG,FDA,FN,LN,MN,RESULT,RGRSICN,SFX,VAL,VAFCA08,X,Y,UPDNC,VAFCDFN,VAFCDOB,VAFCICN,VAFCMMN,VAFCNAM,VAFCPF,VAFCPOBC,VAFCPOBS
+3 NEW VAFCRSN,VAFCSRV,VAFCSSN,VAFCSUM,VAFCSX,VAFCTYP,VAFCVET,VAFCMBI,VAFCPN,VAFCPR,VAFCPC,VAFCPCT,VAFCAL1,VAFCAL2,VAFCAL3,VAFCACY,VAFCAST,VAFCAZ,VAFCACTY,CNTY
+4 NEW VAFCSEQ
SET VAFCSEQ=$$RECORD(.PARAM)
+5 ;allow update to ICN; prevent triggering of messages
SET (RGRSICN,VAFCA08)=1
SET FLG=0
+6 ;PREFERRED FACILITY
+7 IF $GET(PARAM("PRFCLTY"))=""
SET RETURN(1)="-1^PREFERRED FACILITY is a required field."
GOTO END
+8 ;**955 (cmc) Story 699475 don't require perferred facility to be this site if this is station 200
+9 ;**1131 (cmc) VAMPI-26434 allow 741MM to be a perferred facility
+10 IF $PIECE($$SITE^VASITE(),"^",3)'=200&(PARAM("PRFCLTY")'="741MM")
IF $GET(PARAM("PRFCLTY"))'=$PIECE($$SITE^VASITE(),"^",3)
SET RETURN(1)="-1^PREFERRED FACILITY is not the station to which the RPC was sent."
GOTO END
+11 IF $GET(PARAM("PRFCLTY"))'=""&(PARAM("PRFCLTY")'="741MM")
SET VAL=$GET(PARAM("PRFCLTY"))
DO CHK^DIE(2,27.02,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+12 IF $GET(PARAM("PRFCLTY"))'=""
SET VAL=$GET(PARAM("PRFCLTY"))
+13 SET VAFCPF=VAL
SET FLG=1
+14 ;
+15 ;INTEGRATION CONTROL NUMBER and ICN CHECKSUM
+16 IF $GET(PARAM("FULLICN"))=""!($GET(PARAM("FULLICN"))'["V")
SET RETURN(1)="-1^Full INTEGRATION CONTROL NUMBER with ICN CHECKSUM is required."
GOTO END
+17 IF $GET(PARAM("FULLICN"))'=""
SET PARAM("ICN")=$PIECE(PARAM("FULLICN"),"V")
SET PARAM("CHKSUM")=$PIECE(PARAM("FULLICN"),"V",2)
+18 IF $GET(PARAM("ICN"))'=""
SET VAL=$GET(PARAM("ICN"))
DO CHK^DIE(2,991.01,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+19 SET VAFCICN=VAL
SET FLG=1
+20 IF $GET(PARAM("CHKSUM"))'=""
SET VAL=$GET(PARAM("CHKSUM"))
DO CHK^DIE(2,991.02,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+21 SET VAFCSUM=VAL
SET FLG=1
+22 ;Has patient already been created at this facility? If so get DFN and quit.
+23 SET VAFCDFN=+$ORDER(^DPT("AICN",PARAM("ICN"),0))
+24 IF VAFCDFN
Begin DoDot:1
+25 ;**1050,VAMPI-9503 (mko): Make sure the 0 node of the patient exists before quitting with the DFN.
+26 ; If not, kill the erroneous "AICN" index entry and continue
+27 IF $DATA(^DPT(VAFCDFN,0))[0
KILL ^DPT("AICN",PARAM("ICN"),VAFCDFN),VAFCDFN
QUIT
+28 SET RETURN(1)="1^"_$ORDER(^DPT("AICN",PARAM("ICN"),0))_$SELECT($$GETFLAG^VAFCPTED:"^^1",1:"")
End DoDot:1
if $DATA(RETURN(1))
GOTO END
+29 ;
+30 ;NAME INPUT AS:LAST^FIRST^MIDDLE^SUFFIX; MUST BE FORMATTED FOR VISTA INPUT
+31 ;**1099,VAMPI-19828 (mko): Build VistA name in VAFCNAM instead of PARAM("NAME")
+32 IF $GET(PARAM("NAME"))=""
SET RETURN(1)="-1^Patient NAME is a required field."
GOTO END
+33 SET LN=$PIECE($GET(PARAM("NAME")),"^")
SET FN=$PIECE($GET(PARAM("NAME")),"^",2)
SET MN=$PIECE($GET(PARAM("NAME")),"^",3)
SET SFX=$PIECE($GET(PARAM("NAME")),"^",4)
+34 SET VAFCNAM=LN_","
+35 if FN'=""
SET VAFCNAM=VAFCNAM_FN
+36 if MN'=""
SET VAFCNAM=VAFCNAM_" "_MN
+37 if SFX'=""
SET VAFCNAM=VAFCNAM_" "_SFX
+38 DO CHK^DIE(2,.01,,VAFCNAM,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+39 ;variable used by SSN input transform
SET FLG=1
SET DPTX=VAFCNAM
+40 ;
+41 ;DATE OF BIRTH
+42 IF $GET(PARAM("DOB"))=""
SET RETURN(1)="-1^DATE OF BIRTH is a required field."
GOTO END
+43 IF $GET(PARAM("DOB"))'=""
SET VAL=$GET(PARAM("DOB"))
DO CHK^DIE(2,.03,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+44 ;variable used by PSEUDO-SSN code
SET VAFCDOB=VAL
SET FLG=1
SET DPTIDS(.03)=RESULT
+45 ;
+46 ;SOCIAL SECURITY NUMBER not equal null; valid 9-digit number
+47 IF '$DATA(PARAM("SSN"))
SET RETURN(1)="-1^SOCIAL SECURITY NUMBER is a required field. A null value may be sent."
GOTO END
+48 IF $GET(PARAM("SSN"))'=""
SET VAL=$GET(PARAM("SSN"))
DO CHK^DIE(2,.09,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+49 IF $GET(PARAM("SSN"))'=""
SET VAFCSSN=VAL
SET FLG=1
+50 ;SSN null, set PSEUDO SSN REASON=SSN UNKNOWN/FOLLOW-UP
IF $GET(PARAM("SSN"))=""
Begin DoDot:1
+51 ;PSEUDO SSN
SET PARAM("SSN")="P"
+52 ;PSEUDO SSN REASON
SET PARAM("PSEUDO")="S"
+53 SET VAFCSSN=$GET(PARAM("SSN"))
SET FLG=1
+54 ;If SSN null, set PSEUDO SSN REASON (#.0906) =SSN UNKNOWN/FOLLOW-UP
+55 SET VAFCRSN=$GET(PARAM("PSEUDO"))
SET FLG=1
End DoDot:1
+56 ;
+57 ;SEX
+58 IF $GET(PARAM("GENDER"))=""
SET RETURN(1)="-1^GENDER is a required field."
GOTO END
+59 IF $GET(PARAM("GENDER"))'=""
SET VAL=$GET(PARAM("GENDER"))
DO CHK^DIE(2,.02,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+60 SET VAFCSX=VAL
SET FLG=1
+61 ;
+62 ;SERVICE CONNECTED?
+63 IF $GET(PARAM("SRVCNCTD"))=""
SET RETURN(1)="-1^'SERVICE CONNECTED?' is a required field."
GOTO END
+64 ;input set to either YES or NO on the MPI before RPC call; skip CHK^DIE here as it resulted in error; expected DFN variable which is not yet set.
+65 IF $GET(PARAM("SRVCNCTD"))'=""
SET VAFCSRV=$GET(PARAM("SRVCNCTD"))
+66 ;
+67 ;TYPE
+68 IF $GET(PARAM("TYPE"))=""
SET RETURN(1)="-1^Patient TYPE is a required field."
GOTO END
+69 IF $GET(PARAM("TYPE"))'=""
SET VAL=$GET(PARAM("TYPE"))
DO CHK^DIE(2,391,,VAL,.RESULT)
IF RESULT="^"
SET RETURN(1)="-1^"_^TMP("DIERR",$JOB,1,"TEXT",1)
GOTO END
+70 SET VAFCTYP=VAL
SET FLG=1
+71 ;
+72 ;VETERAN Y/N?
+73 IF $GET(PARAM("VET"))=""
SET RETURN(1)="-1^'VETERAN Y/N?' is a required field."
GOTO END
+74 ;input set to either YES or NO on the MPI before RPC call; skip CHK^DIE here as it resulted in error; expected DFN variable which is not yet set.
+75 ;internal format
IF $GET(PARAM("VET"))'=""
SET VAFCVET=$EXTRACT($GET(PARAM("VET")),1)
SET FLG=1
+76 ;
+77 ;Optional - POB CITY
+78 IF $DATA(PARAM("POBCTY"))
SET VAL=$GET(PARAM("POBCTY"))
DO CHK^DIE(2,.092,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("POBCTY")=""
+79 IF $GET(PARAM("POBCTY"))'=""
SET VAFCPOBC=VAL
SET FLG=1
+80 ;
+81 ;Optional - POB STATE
+82 NEW STIEN,UNDEF
SET UNDEF=0
+83 IF $DATA(PARAM("POBST"))
Begin DoDot:1
+84 ;Convert STATE ABBREVIATION into STATE NAME
+85 SET STIEN=$ORDER(^DIC(5,"C",PARAM("POBST"),0))
+86 IF STIEN=""
SET UNDEF=1
QUIT
+87 IF STIEN'=""
SET PARAM("POBST")=$PIECE($GET(^DIC(5,STIEN,0)),"^")
+88 SET VAL=$GET(PARAM("POBST"))
DO CHK^DIE(2,.093,,VAL,.RESULT)
IF RESULT="^"
SET UNDEF=1
QUIT
End DoDot:1
IF UNDEF
SET PARAM("POBST")=""
+89 IF $GET(PARAM("POBST"))'=""
SET VAFCPOBS=VAL
SET FLG=1
+90 ;
+91 ;Optional - MOTHER'S MAIDEN NAME RESET TO NULL IF INVALID VALUE TO ALLOW ADD TO CONTINUE **1033
+92 IF $DATA(PARAM("MMN"))
SET VAL=$GET(PARAM("MMN"))
DO CHK^DIE(2,.2403,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("MMN")=""
+93 IF $GET(PARAM("MMN"))'=""
SET VAFCMMN=VAL
SET FLG=1
+94 ;
+95 ;**876 - MVI_2788 (ckn) - Add MBI
+96 ;Optional - MULTIPLE BIRTH INDICATOR RESET TO NULL IF INVALID VALUE TO ALLOW ADD TO CONTINUE **1033
+97 IF $DATA(PARAM("MBI"))
SET VAL=$GET(PARAM("MBI"))
DO CHK^DIE(2,994,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("MBI")=""
+98 IF $GET(PARAM("MBI"))'=""
SET VAFCMBI=VAL
SET FLG=1
+99 ;
+100 ;**1013 OPTIONAL ADDRESS FIELDS AND PHONE RESET TO NULL IF INVALID VALUE TO ALLOW ADD TO CONTINUE **1033
+101 IF $DATA(PARAM("ResAddL1"))
SET VAL=$GET(PARAM("ResAddL1"))
DO CHK^DIE(2,.111,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddL1")=""
+102 ;ONLY GET LINE2+ IF THE LINE BEFORE WAS GOOD
+103 IF $GET(PARAM("ResAddL1"))'=""
SET VAFCAL1=VAL
SET FLG=1
IF $DATA(PARAM("ResAddL2"))
SET VAL=$GET(PARAM("ResAddL2"))
DO CHK^DIE(2,.112,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddL2")=""
+104 IF $GET(PARAM("ResAddL2"))'=""
SET VAFCAL2=VAL
SET FLG=1
IF $DATA(PARAM("ResAddL3"))
SET VAL=$GET(PARAM("ResAddL3"))
DO CHK^DIE(2,.113,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddL3")=""
+105 IF $GET(PARAM("ResAddL3"))'=""
SET VAFCAL3=VAL
SET FLG=1
+106 IF $DATA(PARAM("ResAddCity"))
SET VAL=$GET(PARAM("ResAddCity"))
DO CHK^DIE(2,.114,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddCity")=""
+107 IF $GET(PARAM("ResAddCity"))'=""
SET VAFCACY=VAL
SET FLG=1
+108 IF $GET(PARAM("ResAddState"))'=""
Begin DoDot:1
+109 ;Convert STATE ABBREVIATION into STATE NAME
+110 SET STIEN=$ORDER(^DIC(5,"C",PARAM("ResAddState"),0))
+111 IF STIEN=""
SET UNDEF=1
QUIT
+112 IF STIEN'=""
SET PARAM("ResAddState")=$PIECE($GET(^DIC(5,STIEN,0)),"^")
+113 SET VAL=$GET(PARAM("ResAddState"))
DO CHK^DIE(2,.115,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddState")=""
End DoDot:1
IF UNDEF
SET PARAM("ResAddState")=""
+114 IF $GET(PARAM("ResAddState"))'=""
SET VAFCAST=VAL
SET FLG=1
+115 IF $DATA(PARAM("ResAddZIP"))
SET VAL=$GET(PARAM("ResAddZIP"))
DO CHK^DIE(2,.1112,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddZIP")=""
+116 IF $GET(PARAM("ResAddZIP"))'=""
SET VAFCAZ=VAL
SET FLG=1
+117 ;**1042,VAMPI-8199 (mko): Get County from Zip Code.
+118 ; State must have a value, as dictated by the input transform of the COUNTY field (#.117) of the PATIENT file (#2).
+119 ; Value to be filed is the subien of the county in the state file
+120 IF $GET(VAFCAZ)]""
IF $GET(VAFCAST)]""
Begin DoDot:1
+121 NEW ARR
+122 DO POSTAL^XIPUTIL(VAFCAZ,.ARR)
if $GET(ARR("COUNTY"))=""
QUIT
+123 SET VAL=$ORDER(^DIC(5,+$GET(STIEN),1,"B",ARR("COUNTY"),0))
+124 if VAL>0
SET VAFCACTY=VAL
End DoDot:1
+125 IF $DATA(PARAM("ResPhone"))
SET VAL=$GET(PARAM("ResPhone"))
DO CHK^DIE(2,.131,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResPhone")=""
+126 IF $GET(PARAM("ResPhone"))'=""
SET VAFCPN=VAL
SET FLG=1
+127 IF $GET(PARAM("ResAddProvince"))'=""
SET VAL=$GET(PARAM("ResAddProvince"))
DO CHK^DIE(2,.1171,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddProvince")=""
+128 IF $GET(PARAM("ResAddProvince"))'=""
SET VAFCPR=VAL
SET FLG=1
+129 ;**1050,VAMPI-9503 (mko): Remove initial I $G(PARAM("ResAddProvince"))'="" test -- don't require a valid Province be sent for Postal Code to be checked
+130 IF $GET(PARAM("ResAddPCode"))'=""
SET VAL=$GET(PARAM("ResAddPCode"))
DO CHK^DIE(2,.1172,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddPCode")=""
+131 IF $GET(PARAM("ResAddPCode"))'=""
SET VAFCPC=VAL
SET FLG=1
+132 ;**1050,VAMPI-9503 (mko): Remove initial I $G(PARAM("ResAddProvince"))'="" test -- don't require a valid Province be sent for Country to be checked
+133 IF $GET(PARAM("ResAddCountry"))'=""
Begin DoDot:1
+134 ;convert Country Abbreviation into Country DESCRIPTION
+135 SET CNTY=$ORDER(^HL(779.004,"B",$GET(PARAM("ResAddCountry")),""))
+136 IF CNTY=""
SET PARAM("ResAddCountry")=""
+137 IF CNTY'=""
SET VAL=PARAM("ResAddCountry")
DO CHK^DIE(2,.1173,,VAL,.RESULT)
IF RESULT="^"
SET PARAM("ResAddCountry")=""
End DoDot:1
+138 IF $GET(PARAM("ResAddCountry"))'=""
SET VAFCPCT=PARAM("ResAddCountry")
SET FLG=1
+139 ;
+140 IF FLG=0
SET RETURN(1)="-1^Required information is missing; please check input and try again."
GOTO END
+141 ;Else ok to file entry
FILE ;Call FILE^DICN to add new entry to PATIENT (#2) file
+1 NEW DA,DIC,DR,FULLICN
KILL DD,DO,VAFCRSLT
+2 SET DIC="^DPT("
SET DIC(0)="FLZ"
SET DLAYGO=2
SET X=VAFCNAM
+3 ;**876 MVI_2788 (ckn) - Remove four slash use for field 1901
+4 ;**944 Story #557843 (cml) add code to update FULL ICN (#991.1), WHO ENTERED PATIENT (#.096), and DATE ENTERED INTO FILE (#.097) fields
+5 SET FULLICN=VAFCICN_"V"_VAFCSUM
+6 SET DIC("DR")=".09///"_VAFCSSN_";.03///"_VAFCDOB_";.02///"_VAFCSX_";391///"_VAFCTYP_";1901///"_VAFCVET_";.301///"_VAFCSRV_";991.01///"_VAFCICN_";991.02///"_VAFCSUM_";991.1///"_FULLICN
+7 IF VAFCSSN="P"
SET DIC("DR")=DIC("DR")_";.0906///"_VAFCRSN
+8 ;
+9 ;**1050,VAMPI-9503 (mko): Separate single FILE^DICN call into one FILE^DICN call to add the record with required fields
+10 ; and a subsequent FILE^DIE call to update the optional fields
+11 LOCK +^DPT(0):10
+12 DO FILE^DICN
KILL DA,DIC,DD,DLAYGO,DO,DR
+13 LOCK -^DPT(0)
+14 ;If record creation/update fails, return a -1^error text
+15 IF $PIECE(Y,U,3)'=1
SET RETURN(1)="-1^"_"Attempt to add patient "_VAFCNAM_" to the PATIENT (#2) file at station number "_$PIECE($$SITE^VASITE,"^",3)_" failed."
GOTO END
+16 SET VAFCDFN=+Y
+17 ;
+18 ;**1050,VAMPI-9503 (mko): After record is created, call FILE^DIE to update the record
+19 Begin DoDot:1
+20 NEW DIERR,DIMSG,DIHELP,FDA,IENS,MSG
+21 SET IENS=VAFCDFN_","
+22 ;POB CITY
if $GET(VAFCPOBC)]""
SET FDA(2,IENS,.092)=VAFCPOBC
+23 ;POB STATE
if $GET(VAFCPOBS)]""
SET FDA(2,IENS,.093)=VAFCPOBS
+24 ;MMN
if $GET(VAFCMMN)]""
SET FDA(2,IENS,.2403)=VAFCMMN
+25 ;**876 - MVI_2788 (ckn)
+26 ;MBI
if $GET(VAFCMBI)]""
SET FDA(2,IENS,994)=VAFCMBI
+27 ;**1033 ADDING ADDRESS FIELDS
+28 ;STREET LINE 1
if $GET(VAFCAL1)]""
SET FDA(2,IENS,.111)=VAFCAL1
+29 ;STREET LINE 2
if $GET(VAFCAL2)]""
SET FDA(2,IENS,.112)=VAFCAL2
+30 ;STREET LINE 3
if $GET(VAFCAL3)]""
SET FDA(2,IENS,.113)=VAFCAL3
+31 ;CITY
if $GET(VAFCACY)]""
SET FDA(2,IENS,.114)=VAFCACY
+32 ;STATE
if $GET(VAFCAST)]""
SET FDA(2,IENS,.115)=VAFCAST
+33 ;ZIP
if $GET(VAFCAZ)]""
SET FDA(2,IENS,.1112)=VAFCAZ
+34 ;PHONE NUMBER
if $GET(VAFCPN)]""
SET FDA(2,IENS,.131)=VAFCPN
+35 ;PROVINCE
if $GET(VAFCPR)]""
SET FDA(2,IENS,.1171)=VAFCPR
+36 ;POSTAL CODE
if $GET(VAFCPC)]""
SET FDA(2,IENS,.1172)=VAFCPC
+37 ;COUNTRY
if $GET(VAFCPCT)]""
SET FDA(2,IENS,.1173)=VAFCPCT
+38 if '$DATA(FDA)
QUIT
+39 LOCK +^DPT(VAFCDFN):10
IF '$TEST
QUIT
+40 DO FILE^DIE("E","FDA","MSG")
LOCK -^DPT(VAFCDFN)
End DoDot:1
+41 ;
+42 ;**1042,VAMPI-8199 (mko): File County (determined from Zip); Need to use 4-slash stuff because IT is interative
+43 ; when county name matches more than one entry (e.g., BALTIMORE and BALTIMORE (CITY)
+44 ;**1050,VAMPI-9503 (mko): Use FILE^DIE to file county instead of FILE^DICN
+45 if $GET(VAFCACTY)]""
Begin DoDot:1
+46 NEW DIERR,DIMSG,DIHELP,FDA,MSG
+47 ;COUNTY
SET FDA(2,VAFCDFN_",",.117)=VAFCACTY
+48 LOCK +^DPT(VAFCDFN):10
IF '$TEST
QUIT
+49 DO FILE^DIE("","FDA","MSG")
LOCK -^DPT(VAFCDFN)
End DoDot:1
+50 ;
+51 ;**1050,VAMPI-9503 (mko): If NC flag is set, file the name components
+52 KILL UPDNC
IF $$GETFLAG^VAFCPTED
SET UPDNC=$$UPDNC(VAFCDFN,$GET(PARAM("LONGNAME"),$GET(PARAM("NAME"))))
+53 ;
+54 ;**1033 VAMPI-12 (jfw) - Interfacility Consult (IFC) support
+55 ; Trigger enrollment/eligibility HL7 messaging to further update patient info
+56 if ($GET(PARAM("ENROLLMENT"))=1)
SET VAFCRSLT=$$QRY^DGENQRY(VAFCDFN)
+57 ; file Who and When if not already done
+58 NEW DGZ,FDA
+59 SET DGZ=$GET(^DPT(VAFCDFN,0))
+60 if '$PIECE(DGZ,"^",15)
SET FDA(2,VAFCDFN_",",.096)=DUZ
+61 if '$PIECE(DGZ,"^",16)
SET FDA(2,VAFCDFN_",",.097)=DT
+62 if $DATA(FDA)
DO FILE^DIE("","FDA")
+63 ;
+64 ;File ALIAS multiple
+65 ;If ALIAS data is passed, call ALIAS module
IF $DATA(PARAM("ALIAS"))
DO ALIAS
+66 ;No errors for ALIAS, return DFN
IF $GET(ALSERR)=""
SET RETURN(1)="1^"_VAFCDFN
+67 IF $GET(ALSERR)'=""
SET RETURN(1)=ALSERR
+68 ;
+69 ;**1050,VAMPI-9503 (mko): If the components of the name were filed, return 4th piece equal to 1
+70 if $GET(UPDNC)
SET $PIECE(RETURN(1),U,4)=1
+71 ;
END ;**1050,VAMPI-9503 (mko): Record return value and quit
+1 DO RETURN(VAFCSEQ,.RETURN)
+2 QUIT
+3 ;
ALIAS ;Optional - Add ALIAS and ALIAS SSN data for entry
+1 ;Only occurs for a NEW record; there is no previous ALIAS data
+2 IF '$DATA(PARAM("ALIAS"))
QUIT
+3 ;ALIAS input comes in as: LAST^FIRST^MIDDLE^SUFFIX^SSN
+4 NEW AFN,ALN,AMN,ASFX,ASSN,ERR,FDA,I,LOC,NUM
+5 SET (I,NUM)=0
FOR
SET NUM=$ORDER(PARAM("ALIAS",NUM))
if 'NUM
QUIT
Begin DoDot:1
+6 ;Last name minimal input
SET ALN=$PIECE($GET(PARAM("ALIAS",NUM)),"^")
if ALN=""
QUIT
+7 SET AFN=$PIECE($GET(PARAM("ALIAS",NUM)),"^",2)
SET AMN=$PIECE($GET(PARAM("ALIAS",NUM)),"^",3)
+8 SET ASFX=$PIECE($GET(PARAM("ALIAS",NUM)),"^",4)
SET ASSN=$PIECE($GET(PARAM("ALIAS",NUM)),"^",5)
+9 ;Change format for VistA input: LAST,FIRST MIDDLE SUFFIX^SSN
+10 SET LOC(NUM)=ALN_","
+11 IF AFN'=""
SET LOC(NUM)=LOC(NUM)_AFN
+12 IF AMN'=""
SET LOC(NUM)=LOC(NUM)_" "_AMN
+13 IF ASFX'=""
SET LOC(NUM)=LOC(NUM)_" "_ASFX
+14 SET LOC(NUM)=LOC(NUM)_"^"
+15 IF ASSN'=""
SET LOC(NUM)=LOC(NUM)_ASSN
+16 ;Set FDA nodes
+17 ;Unique sequence number for add to ALIAS SUB-FILE (#2.01
SET I=I+1
+18 ; (#.01) ALIAS (name)
SET FDA(2.01,"+"_I_","_VAFCDFN_",",.01)=$PIECE(LOC(NUM),"^")
+19 ; (#1) ALIAS SSN
IF ASSN'=""
SET FDA(2.01,"+"_I_","_VAFCDFN_",",1)=$PIECE(LOC(NUM),"^",2)
End DoDot:1
+20 ;Update ALIAS multiple with new entries
+21 ;We have ALIAS data to add
IF $DATA(FDA)
Begin DoDot:1
+22 SET ALSERR=""
+23 LOCK +^DPT(VAFCDFN):10
DO UPDATE^DIE("E","FDA",,"ERR")
LOCK -^DPT(VAFCDFN)
+24 IF $DATA(ERR("DIERR"))
SET ALSERR="1^"_VAFCDFN_"^Patient "_PARAM("NAME")_" was successfully added at "_$PIECE($$SITE^VASITE,"^",3)_". However, the ALIAS data failed to update. Error message: "_$GET(ERR("DIERR","1","TEXT",1))
QUIT
End DoDot:1
+25 QUIT
+26 ;
UPDNC(VAFCDFN,NAME) ;Update name components; Return 1 if updated
+1 ;**1050,VAMPI-9503 (mko): New subroutine
+2 NEW CURR,DIERR,DIMSG,DIHELP,FDA,MSG,NCIENS
+3 if $GET(NAME)?."^"
QUIT 0
+4 if $GET(VAFCDFN)'>0
QUIT 0
+5 SET NCIENS=$PIECE($GET(^DPT(+VAFCDFN,"NAME")),U)_","
if 'NCIENS
QUIT 0
+6 ;
+7 ;Get current values
+8 DO GETS^DIQ(20,NCIENS,"1;2;3;5","","CURR","MSG")
if $GET(DIERR)
QUIT 0
+9 ;
+10 ;**1099,VAMPI-19828 (mko): Quit 0 if there are no differences
+11 SET CURR("NAME")=CURR(20,NCIENS,1)_U_CURR(20,NCIENS,2)_U_CURR(20,NCIENS,3)_U_CURR(20,NCIENS,5)_U
+12 SET $PIECE(NAME,U,5)=""
+13 if CURR("NAME")=NAME
QUIT 0
+14 ;
+15 ;**1099,VAMPI-19828 (mko): Set FDA for each component even if not different from current
+16 ; so that FILE^DIE can check that all are valid before any are filed.
+17 SET FDA(20,NCIENS,1)=$PIECE(NAME,U)
+18 SET FDA(20,NCIENS,2)=$PIECE(NAME,U,2)
+19 SET FDA(20,NCIENS,3)=$PIECE(NAME,U,3)
+20 SET FDA(20,NCIENS,5)=$PIECE(NAME,U,4)
+21 ;
+22 ;Call Filer
+23 DO FILE^DIE("EKT","FDA","MSG")
+24 QUIT '$GET(DIERR)
+25 ;
+26 ;=================================================
+27 ; Code for storing debugging information in ^XTMP
+28 ;=================================================
RECORD(PARAM,RPCNAME) ;Record RPC inputs for debugging
+1 ;Return seq# in ^XTMP
+2 NEW NODE,NOW,SEQ,TODAY
+3 if '$$ISDEBUG
QUIT 0
+4 if $GET(RPCNAME)=""
SET RPCNAME="VAFC VOA ADD PATIENT"
+5 SET NOW=$$NOW^XLFDT
SET TODAY=$PIECE(NOW,".")
+6 SET NODE=$$NODE
+7 ;
+8 LOCK +^XTMP(NODE):2
+9 DO SETXTMP0(NODE)
+10 SET SEQ=$ORDER(^XTMP(NODE," "),-1)+1
+11 MERGE ^XTMP(NODE,SEQ,"PARAM")=PARAM
+12 SET ^XTMP(NODE,SEQ,"DT")=NOW
+13 SET ^XTMP(NODE,SEQ,"DUZ")=$GET(DUZ)
+14 SET ^XTMP(NODE,SEQ,"RPC")=RPCNAME
+15 LOCK -^XTMP(NODE)
+16 QUIT SEQ
+17 ;
RETURN(SEQ,RETURN) ;Record the return value
+1 if 'SEQ
QUIT
if '$$ISDEBUG
QUIT
+2 MERGE ^XTMP($$NODE,SEQ,"RETURN")=RETURN
+3 QUIT
+4 ;
DBON ;Set DEBUG on
+1 NEW NODE
+2 SET NODE=$$NODE
+3 DO SETXTMP0
+4 SET ^XTMP(NODE,"DEBUG")=1
+5 WRITE !,$NAME(^XTMP(NODE,"DEBUG"))_" set to 1.",!
+6 QUIT
+7 ;
DBOFF ;Set DEBUG off
+1 NEW NODE
+2 SET NODE=$$NODE
+3 KILL ^XTMP(NODE,"DEBUG")
+4 if '$ORDER(^XTMP(NODE,0))
KILL ^XTMP(NODE)
+5 WRITE !,$NAME(^XTMP(NODE,"DEBUG"))_" killed.",!
+6 QUIT
+7 ;
ISDEBUG() ;Return 1 if DEBUG mode flag is set
+1 QUIT $GET(^XTMP($$NODE,"DEBUG"))
+2 ;
PURGE ;Purge the debugging data stored in ^XTMP
+1 NEW ISDEBUG
+2 SET ISDEBUG=$$ISDEBUG
+3 KILL ^XTMP($$NODE)
+4 WRITE !,$NAME(^XTMP($$NODE))_" killed.",!
+5 if ISDEBUG
DO DBON
+6 QUIT
+7 ;
SETXTMP0(NODE,DESC,LIFE) ;Set 0 node of ^XTMP(node)
+1 NEW CREATEDT
+2 if $GET(NODE)=""
SET NODE=$$NODE
+3 SET CREATEDT=$SELECT($DATA(^XTMP(NODE,0))#2:$PIECE(^(0),U,2),1:DT)
+4 if '$GET(LIFE)
SET LIFE=30
+5 if $GET(DESC)=""
SET DESC="Inputs and Outputs to RPC: VAFC VOA ADD PATIENT"
+6 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,LIFE)_U_CREATEDT_U_DESC
+7 QUIT
+8 ;
NODE() ;Return ^XTMP Debug subscript
+1 QUIT "VAFC_VOA_ADD_PATIENT"
