Released DG*5.3*974 SEQ #855 Extracted from mail message **KIDS**:DG*5.3*974^ **INSTALL NAME** DG*5.3*974 "BLD",3372,0) DG*5.3*974^REGISTRATION^0^3190116^y "BLD",3372,1,0) ^^3^3^3190116^ "BLD",3372,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENTS - SUPPORT LONG NAMES IN VA MPI "BLD",3372,1,2,0) Refer to patch DG*5.3*974 in the FORUM Patch Module for a complete "BLD",3372,1,3,0) description. "BLD",3372,4,0) ^9.64PA^^ "BLD",3372,6.3) 2 "BLD",3372,"KRN",0) ^9.67PA^1.61^23 "BLD",3372,"KRN",.4,0) .4 "BLD",3372,"KRN",.401,0) .401 "BLD",3372,"KRN",.402,0) .402 "BLD",3372,"KRN",.403,0) .403 "BLD",3372,"KRN",.5,0) .5 "BLD",3372,"KRN",.84,0) .84 "BLD",3372,"KRN",1.6,0) 1.6 "BLD",3372,"KRN",1.61,0) 1.61 "BLD",3372,"KRN",1.62,0) 1.62 "BLD",3372,"KRN",3.6,0) 3.6 "BLD",3372,"KRN",3.8,0) 3.8 "BLD",3372,"KRN",9.2,0) 9.2 "BLD",3372,"KRN",9.8,0) 9.8 "BLD",3372,"KRN",9.8,"NM",0) ^9.68A^5^5 "BLD",3372,"KRN",9.8,"NM",1,0) DGNAME^^0^B7077363 "BLD",3372,"KRN",9.8,"NM",2,0) VAFCMSG^^0^B21014587 "BLD",3372,"KRN",9.8,"NM",3,0) VAFCPDT2^^0^B40397763 "BLD",3372,"KRN",9.8,"NM",4,0) VAFCPTED^^0^B45940753 "BLD",3372,"KRN",9.8,"NM",5,0) VAFCQRY1^^0^B93833983 "BLD",3372,"KRN",9.8,"NM","B","DGNAME",1) "BLD",3372,"KRN",9.8,"NM","B","VAFCMSG",2) "BLD",3372,"KRN",9.8,"NM","B","VAFCPDT2",3) "BLD",3372,"KRN",9.8,"NM","B","VAFCPTED",4) "BLD",3372,"KRN",9.8,"NM","B","VAFCQRY1",5) "BLD",3372,"KRN",19,0) 19 "BLD",3372,"KRN",19.1,0) 19.1 "BLD",3372,"KRN",101,0) 101 "BLD",3372,"KRN",409.61,0) 409.61 "BLD",3372,"KRN",771,0) 771 "BLD",3372,"KRN",779.2,0) 779.2 "BLD",3372,"KRN",870,0) 870 "BLD",3372,"KRN",8989.51,0) 8989.51 "BLD",3372,"KRN",8989.52,0) 8989.52 "BLD",3372,"KRN",8994,0) 8994 "BLD",3372,"KRN",8994,"NM",0) ^9.68A^1^1 "BLD",3372,"KRN",8994,"NM",1,0) DG UPDATE NAME COMPONENTS^^0 "BLD",3372,"KRN",8994,"NM","B","DG UPDATE NAME COMPONENTS",1) "BLD",3372,"KRN","B",.4,.4) "BLD",3372,"KRN","B",.401,.401) "BLD",3372,"KRN","B",.402,.402) "BLD",3372,"KRN","B",.403,.403) "BLD",3372,"KRN","B",.5,.5) "BLD",3372,"KRN","B",.84,.84) "BLD",3372,"KRN","B",1.6,1.6) "BLD",3372,"KRN","B",1.61,1.61) "BLD",3372,"KRN","B",1.62,1.62) "BLD",3372,"KRN","B",3.6,3.6) "BLD",3372,"KRN","B",3.8,3.8) "BLD",3372,"KRN","B",9.2,9.2) "BLD",3372,"KRN","B",9.8,9.8) "BLD",3372,"KRN","B",19,19) "BLD",3372,"KRN","B",19.1,19.1) "BLD",3372,"KRN","B",101,101) "BLD",3372,"KRN","B",409.61,409.61) "BLD",3372,"KRN","B",771,771) "BLD",3372,"KRN","B",779.2,779.2) "BLD",3372,"KRN","B",870,870) "BLD",3372,"KRN","B",8989.51,8989.51) "BLD",3372,"KRN","B",8989.52,8989.52) "BLD",3372,"KRN","B",8994,8994) "BLD",3372,"QDEF") ^^^^NO^^^^NO^^YES "BLD",3372,"QUES",0) ^9.62^^ "BLD",3372,"REQB",0) ^9.611^4^4 "BLD",3372,"REQB",1,0) DG*5.3*578^2 "BLD",3372,"REQB",2,0) DG*5.3*837^2 "BLD",3372,"REQB",3,0) DG*5.3*937^2 "BLD",3372,"REQB",4,0) DG*5.3*944^2 "BLD",3372,"REQB","B","DG*5.3*578",1) "BLD",3372,"REQB","B","DG*5.3*837",2) "BLD",3372,"REQB","B","DG*5.3*937",3) "BLD",3372,"REQB","B","DG*5.3*944",4) "KRN",8994,724,-1) 0^1 "KRN",8994,724,0) DG UPDATE NAME COMPONENTS^UPDNC^DGNAME^2^P^^^^1^^0 "KRN",8994,724,1,0) ^8994.01^2^2^3181214^^ "KRN",8994,724,1,1,0) This Remote Procedure updates or retrieves values in a NAME COMPONENTS "KRN",8994,724,1,2,0) file (#20) entry. "KRN",8994,724,2,0) ^8994.02A^3^3 "KRN",8994,724,2,1,0) FLAG^1^^^1 "KRN",8994,724,2,1,1,0) ^8994.021^13^13^3181214^^ "KRN",8994,724,2,1,1,1,0) This parameter acts as a flag to control how the Remote Procedure "KRN",8994,724,2,1,1,2,0) functions. If it contains a "G", the Remote Procedure operates in "GET" "KRN",8994,724,2,1,1,3,0) mode and returns the values of the following fields in the NAME "KRN",8994,724,2,1,1,4,0) COMPONENTS file (#20): "KRN",8994,724,2,1,1,5,0) "KRN",8994,724,2,1,1,6,0) FAMILY (LAST) NAME (#1) "KRN",8994,724,2,1,1,7,0) GIVEN (FIRST) NAME (#2) "KRN",8994,724,2,1,1,8,0) MIDDLE NAME (#3) "KRN",8994,724,2,1,1,9,0) SUFFIX (#5) "KRN",8994,724,2,1,1,10,0) "KRN",8994,724,2,1,1,11,0) If the parameter does not contain a "G", the Remote Procedure operates in "KRN",8994,724,2,1,1,12,0) "UPDATE" mode and is used to set the values of the above fields to the "KRN",8994,724,2,1,1,13,0) values passed in the NAME COMPONENTS parameter. "KRN",8994,724,2,2,0) IEN^1^^1^2 "KRN",8994,724,2,2,1,0) ^8994.021^10^10^3181214^^ "KRN",8994,724,2,2,1,1,0) This parameter contain is the IEN of either an entry in the PATIENT file "KRN",8994,724,2,2,1,2,0) (#2), or an entry in the NAME COMPONENTS file (#20), depending on whether "KRN",8994,724,2,2,1,3,0) this remote procedure is being called in GET or UPDATE mode. "KRN",8994,724,2,2,1,4,0) "KRN",8994,724,2,2,1,5,0) If the FLAG parameter contains a "G" (GET mode), IEN is the DFN of the "KRN",8994,724,2,2,1,6,0) PATIENT file entry for which the NAME and ALIAS name components should be "KRN",8994,724,2,2,1,7,0) returned. "KRN",8994,724,2,2,1,8,0) "KRN",8994,724,2,2,1,9,0) If the FLAG parameter does not contain a "G" (UPDATE mode), IEN is the "KRN",8994,724,2,2,1,10,0) IEN of the NAME COMPONENTS file entry to update. "KRN",8994,724,2,3,0) NAME COMPONENTS^2^^^3 "KRN",8994,724,2,3,1,0) ^^16^16^3181121^ "KRN",8994,724,2,3,1,1,0) If this Remote Procedure is being called in UPDATE mode (i.e., the FLAG "KRN",8994,724,2,3,1,2,0) parameter does not contain a "G"), then this parameter contain the values "KRN",8994,724,2,3,1,3,0) to file in the NAME COMPONENTS file (#20) entry with the IEN passed. It is "KRN",8994,724,2,3,1,4,0) an array with the following format: "KRN",8994,724,2,3,1,5,0) "KRN",8994,724,2,3,1,6,0) ARRAY("FAMILY") = The Family (Last) Name "KRN",8994,724,2,3,1,7,0) ARRAY("GIVEN") = The Given (First) Name "KRN",8994,724,2,3,1,8,0) ARRAY("MIDDLE") = The Middle Name "KRN",8994,724,2,3,1,9,0) ARRAY("SUFFIX") = The Suffix "KRN",8994,724,2,3,1,10,0) "KRN",8994,724,2,3,1,11,0) To delete the value of a Name Component field, the array element can be "KRN",8994,724,2,3,1,12,0) set to "" or "@". To keep the value of a specific name component "KRN",8994,724,2,3,1,13,0) unchanged, don't pass that array element. "KRN",8994,724,2,3,1,14,0) "KRN",8994,724,2,3,1,15,0) If this Remote Procedure is being called in GET mode (i.e., the FLAG "KRN",8994,724,2,3,1,16,0) parameter contains a "G"), then this parameter is ignored. "KRN",8994,724,2,"B","FLAG",1) "KRN",8994,724,2,"B","IEN",2) "KRN",8994,724,2,"B","NAME COMPONENTS",3) "KRN",8994,724,2,"PARAMSEQ",1,1) "KRN",8994,724,2,"PARAMSEQ",2,2) "KRN",8994,724,2,"PARAMSEQ",3,3) "KRN",8994,724,3,0) ^8994.03^24^24^3181214^^ "KRN",8994,724,3,1,0) If the FLAG parameter contains a "G" (GET mode), the following array will "KRN",8994,724,3,2,0) be returned: "KRN",8994,724,3,3,0) "KRN",8994,724,3,4,0) RETURN(0) = ^ "KRN",8994,724,3,5,0) ^^^ "KRN",8994,724,3,6,0) RETURN(1) = ^ "KRN",8994,724,3,7,0) ^^^ "KRN",8994,724,3,8,0) RETURN(2) = ^ "KRN",8994,724,3,9,0) ^^^ "KRN",8994,724,3,10,0) ... "KRN",8994,724,3,11,0) "KRN",8994,724,3,12,0) or, if there are errors, the returned array has the following format: "KRN",8994,724,3,13,0) "KRN",8994,724,3,14,0) RETURN(0) = -1^Patient with DFN cannot be found. "KRN",8994,724,3,15,0) RETURN(0) = -1^ "KRN",8994,724,3,16,0) "KRN",8994,724,3,17,0) If the FLAG parameter does not contain a "G" (UPDATE mode), the following "KRN",8994,724,3,18,0) array node is returned: "KRN",8994,724,3,19,0) "KRN",8994,724,3,20,0) RETURN(0) = 1^ "KRN",8994,724,3,21,0) "KRN",8994,724,3,22,0) or if there is an error, the following is returned: "KRN",8994,724,3,23,0) "KRN",8994,724,3,24,0) RETURN(0) = -1^ "MBREQ") 0 "ORD",16,8994) 8994;16;1;;;;RPCE1^XPDIA1;;;RPCDEL^XPDIA1 "ORD",16,8994,0) REMOTE PROCEDURE "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813^2970721^12541 "PKG",5,22,1,"PAH",1,0) 974^3190116 "PKG",5,22,1,"PAH",1,1,0) ^^3^3^3190116 "PKG",5,22,1,"PAH",1,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENTS - SUPPORT LONG NAMES IN VA MPI "PKG",5,22,1,"PAH",1,1,2,0) Refer to patch DG*5.3*974 in the FORUM Patch Module for a complete "PKG",5,22,1,"PAH",1,1,3,0) description. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 5 "RTN","DGNAME") 0^1^B7077363^n/a "RTN","DGNAME",1,0) DGNAME ;SFISC/MKO-PATIENT NAME UTILITIES ;4 Dec 2018 11:53 AM "RTN","DGNAME",2,0) ;;5.3;Registration;**974**;Aug 13, 1993;Build 2 "RTN","DGNAME",3,0) ;**974,Story 841921 (mko): New routine for updating Name Components "RTN","DGNAME",4,0) Q "RTN","DGNAME",5,0) ; "RTN","DGNAME",6,0) UPDNC(RETURN,FLAG,IEN,NEWNC) ;Remote Procedure DG UPDATE NAME COMPONENTS "RTN","DGNAME",7,0) ; FLAG : "G" - "GET" mode, Name and Aliases should be returned, not updated "RTN","DGNAME",8,0) ; Otherwise, the Name Components entry IEN will be updated with values in NEWNC array "RTN","DGNAME",9,0) ; IEN : If FLAG["G", IEN is the DFN of the Patient whose name and alias should be returned "RTN","DGNAME",10,0) ; If FLAG'["G", IEN is the IEN of the Name Components entry to update "RTN","DGNAME",11,0) ; NEWNC : Array of name components, with subscripts: "FAMILY", "GIVEN", "MIDDLE", and "SUFFIX" "RTN","DGNAME",12,0) N DIERR,DIHELP,DIMSG,DIRUT,DTOUT,DUOUT,ERRARR,ERRMSG,FDA,MSG,IENS "RTN","DGNAME",13,0) S FLAG=$G(FLAG) "RTN","DGNAME",14,0) ; "RTN","DGNAME",15,0) ;Get corresponding Name Components entry "RTN","DGNAME",16,0) I FLAG["G" D GETNAMES(.RETURN,IEN) Q "RTN","DGNAME",17,0) ; "RTN","DGNAME",18,0) I '$G(IEN) S RETURN="-1^Name Components IEN not passed." Q "RTN","DGNAME",19,0) I $P($G(^VA(20,IEN,0)),U)="" S RETURN="-1^Name Components entry IEN "_IEN_" not found." Q "RTN","DGNAME",20,0) ; "RTN","DGNAME",21,0) ;Setup FDA array for Name CURVAL "RTN","DGNAME",22,0) S IENS=IEN_"," "RTN","DGNAME",23,0) S:$D(NEWNC("FAMILY"))#2 FDA(20,IENS,1)=NEWNC("FAMILY") "RTN","DGNAME",24,0) S:$D(NEWNC("GIVEN"))#2 FDA(20,IENS,2)=NEWNC("GIVEN") "RTN","DGNAME",25,0) S:$D(NEWNC("MIDDLE"))#2 FDA(20,IENS,3)=NEWNC("MIDDLE") "RTN","DGNAME",26,0) S:$D(NEWNC("SUFFIX"))#2 FDA(20,IENS,5)=NEWNC("SUFFIX") "RTN","DGNAME",27,0) S FDA(20,IENS,7)="CL30" "RTN","DGNAME",28,0) D FILE^DIE("ET","FDA","MSG") "RTN","DGNAME",29,0) ; "RTN","DGNAME",30,0) ;If error, return error message(s) "RTN","DGNAME",31,0) I $G(DIERR) S RETURN="-1^"_$$BLDERR("MSG") Q "RTN","DGNAME",32,0) ; "RTN","DGNAME",33,0) S RETURN="1^"_IEN "RTN","DGNAME",34,0) Q "RTN","DGNAME",35,0) ; "RTN","DGNAME",36,0) GETNAMES(RETURN,PATIEN) ;Get the Name and Aliases "RTN","DGNAME",37,0) N ALSIEN,NCIEN "RTN","DGNAME",38,0) K RETURN "RTN","DGNAME",39,0) ; "RTN","DGNAME",40,0) I '$G(PATIEN) S RETURN="-1^DFN was not passed." Q "RTN","DGNAME",41,0) I $P($G(^DPT(PATIEN,0)),U)="" S RETURN="-1^Patient with DFN "_PATIEN_" not found." Q "RTN","DGNAME",42,0) ; "RTN","DGNAME",43,0) ;Get Name Components for Patient Name "RTN","DGNAME",44,0) S NCIEN=$P($G(^DPT(PATIEN,"NAME")),U) "RTN","DGNAME",45,0) I NCIEN D GETCOMP(.RETURN,NCIEN) Q:$G(RETURN)<0 "RTN","DGNAME",46,0) ; "RTN","DGNAME",47,0) ;Get each Alias "RTN","DGNAME",48,0) S ALSIEN=0 F S ALSIEN=$O(^DPT(PATIEN,.01,ALSIEN)) Q:'ALSIEN D Q:$G(RETURN)<0 "RTN","DGNAME",49,0) . S NCIEN=$P($G(^DPT(PATIEN,.01,ALSIEN,0)),U,3) "RTN","DGNAME",50,0) . I NCIEN D GETCOMP(.RETURN,NCIEN) "RTN","DGNAME",51,0) Q "RTN","DGNAME",52,0) ; "RTN","DGNAME",53,0) GETCOMP(RETURN,NCIEN) ;Get the Name Components into the RETURN array "RTN","DGNAME",54,0) N DIERR,DIHELP,DIMSG,NCIENS,TARG,MSG "RTN","DGNAME",55,0) S NCIENS=NCIEN_"," "RTN","DGNAME",56,0) D GETS^DIQ(20,NCIENS,"1;2;3;5","","TARG","MSG") "RTN","DGNAME",57,0) I $G(DIERR) S RETURN="-1^"_$$BLDERR("MSG") Q "RTN","DGNAME",58,0) S RETURN($O(RETURN(""),-1)+1)=NCIEN_U_$G(TARG(20,NCIENS,1))_U_$G(TARG(20,NCIENS,2))_U_$G(TARG(20,NCIENS,3))_U_$G(TARG(20,NCIENS,5)) "RTN","DGNAME",59,0) Q "RTN","DGNAME",60,0) ; "RTN","DGNAME",61,0) BLDERR(MSGROOT) ;Build an error from the error message array "RTN","DGNAME",62,0) N ERRARR,ERRMSG,I "RTN","DGNAME",63,0) D MSG^DIALOG("AE",.ERRARR,"","",MSGROOT) "RTN","DGNAME",64,0) S ERRMSG="",I=0 F S I=$O(ERRARR(I)) Q:'I S ERRMSG=ERRMSG_$S(ERRMSG]"":" ",1:"")_$G(ERRARR(I)) "RTN","DGNAME",65,0) Q ERRMSG "RTN","VAFCMSG") 0^2^B21014587^B18003001 "RTN","VAFCMSG",1,0) VAFCMSG ;ALB/JRP-BACKGROUND JOB TO TRANSMIT ENTRIES IN PIVOT FILE ;7 Dec 2018 3:39 PM "RTN","VAFCMSG",2,0) ;;5.3;Registration;**91,149,530,578,974**;Jun 06, 1996;Build 2 "RTN","VAFCMSG",3,0) ; "RTN","VAFCMSG",4,0) MAIN ;Main entry point for background job "RTN","VAFCMSG",5,0) ; "RTN","VAFCMSG",6,0) ;attempt to lock non existant global. "RTN","VAFCMSG",7,0) L +^VAT(391.71,"VAFC BATCH UPDATE ADT/HL7"):1 I '$T Q "RTN","VAFCMSG",8,0) ;Send messages ? 0=STOP,2=SUSPEND "RTN","VAFCMSG",9,0) N SEND "RTN","VAFCMSG",10,0) S SEND=$P($$SEND^VAFHUTL(),"^",2) "RTN","VAFCMSG",11,0) I (SEND=0)!(SEND=2) L -^VAT(391.71,"VAFC BATCH UPDATE ADT/HL7") Q "RTN","VAFCMSG",12,0) ;Send Registration messages "RTN","VAFCMSG",13,0) D BCSTA04 "RTN","VAFCMSG",14,0) ;Send changes to patient's demographical data (ADT-A08) "RTN","VAFCMSG",15,0) D BCSTA08 "RTN","VAFCMSG",16,0) ;Send changes to patient's treating facility list (MFU-M05) "RTN","VAFCMSG",17,0) D BCKTFMFU^VAFCTFMF "RTN","VAFCMSG",18,0) ;unlock global "RTN","VAFCMSG",19,0) L -^VAT(391.71,"VAFC BATCH UPDATE ADT/HL7") "RTN","VAFCMSG",20,0) ;K DIC,X,Y "RTN","VAFCMSG",21,0) Q "RTN","VAFCMSG",22,0) ; "RTN","VAFCMSG",23,0) BCSTA08 ;Broadcast ADT-A08 messages for all entries in ADT/HL PIVOT file "RTN","VAFCMSG",24,0) ;(#391.71) that have been marked for transmission "RTN","VAFCMSG",25,0) ; "RTN","VAFCMSG",26,0) ;Input : None "RTN","VAFCMSG",27,0) ;Output : None "RTN","VAFCMSG",28,0) ; "RTN","VAFCMSG",29,0) ;Declare variables "RTN","VAFCMSG",30,0) N PIVOTPTR,NODE,DFN,EDITDATE,TMP,INFOARR "RTN","VAFCMSG",31,0) S INFOARR="^TMP(""VAFCMSG"","_$J_",""EVNTINFO"")" "RTN","VAFCMSG",32,0) K @INFOARR "RTN","VAFCMSG",33,0) ;Loop through pivot file based on demographic updates "RTN","VAFCMSG",34,0) S PIVOTPTR=0 "RTN","VAFCMSG",35,0) F S PIVOTPTR=+$O(^VAT(391.71,"AXMIT",4,PIVOTPTR)) Q:('PIVOTPTR) D "RTN","VAFCMSG",36,0) .;Bad entry in cross reference - delete it and quit "RTN","VAFCMSG",37,0) .I ('$D(^VAT(391.71,PIVOTPTR))) K ^VAT(391.71,"AXMIT",4,PIVOTPTR) Q "RTN","VAFCMSG",38,0) .;Get event date and pointer to patient "RTN","VAFCMSG",39,0) .S NODE=$G(^VAT(391.71,PIVOTPTR,0)) "RTN","VAFCMSG",40,0) .S EDITDATE=+NODE "RTN","VAFCMSG",41,0) .S DFN=+$P(NODE,"^",3) "RTN","VAFCMSG",42,0) .;PATCH 530 check global for lock status - quit if locked. "RTN","VAFCMSG",43,0) .L +^DPT(DFN):1 I '$T Q "RTN","VAFCMSG",44,0) .;Bad pointer to patient - mark entry as transmitted and quit "RTN","VAFCMSG",45,0) .I ('$D(^DPT(DFN,0)))!($G(^DPT(DFN,-9))) D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) Q "RTN","VAFCMSG",46,0) .I $P(^DPT(DFN,0),U)="" D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) Q "RTN","VAFCMSG",47,0) .;**974,Story 841921 (mko): If name components were edited, a bug "RTN","VAFCMSG",48,0) .; in UPDNAME^XLFNAME could allow the .01 to be more than 30 characters. "RTN","VAFCMSG",49,0) .I '$D(^DPT("B",$E($P(^DPT(DFN,0),U),1,30),DFN)) D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) Q "RTN","VAFCMSG",50,0) .;Store info into event information array "RTN","VAFCMSG",51,0) .K @INFOARR "RTN","VAFCMSG",52,0) .S @INFOARR@("PIVOT")=PIVOTPTR "RTN","VAFCMSG",53,0) .;Event reason code "RTN","VAFCMSG",54,0) .; 99 = Death 98 = Resurrection 97=Sensitivity Update "RTN","VAFCMSG",55,0) .; Death will overwrite any other reason code. It is the "RTN","VAFCMSG",56,0) .; dominant reason code. "RTN","VAFCMSG",57,0) .S @INFOARR@("REASON",1)="" "RTN","VAFCMSG",58,0) .S @INFOARR@("REASON",1)=$P($G(^VAT(391.71,PIVOTPTR,0)),"^",10) "RTN","VAFCMSG",59,0) .I (+$G(^DPT(DFN,.35))) S @INFOARR@("REASON",1)=99 "RTN","VAFCMSG",60,0) .; "RTN","VAFCMSG",61,0) .; user/operator name from duz "RTN","VAFCMSG",62,0) .S DIC="^VA(200,",DIC(0)="MZO",X="`"_+$P(NODE,"^",9) D ^DIC "RTN","VAFCMSG",63,0) .S @INFOARR@("USER")=$P($G(Y),"^",2) "RTN","VAFCMSG",64,0) .; "RTN","VAFCMSG",65,0) .S @INFOARR@("EVENT-NUM")=$P(NODE,"^",2) "RTN","VAFCMSG",66,0) .S @INFOARR@("VAR-PTR")=$P(NODE,"^",5) "RTN","VAFCMSG",67,0) .; "RTN","VAFCMSG",68,0) .;Broadcast ADT-A08 message "RTN","VAFCMSG",69,0) .S TMP=$$BCSTADT^VAFCMSG0(DFN,"A08",EDITDATE,INFOARR) "RTN","VAFCMSG",70,0) .;Store result in pivot file "RTN","VAFCMSG",71,0) .S:$P(TMP,U,2)]"" TMP=$P(TMP,U,2) D FILERM^VAFCUTL(PIVOTPTR,TMP) "RTN","VAFCMSG",72,0) .;Error broadcasting message "RTN","VAFCMSG",73,0) .Q:(TMP<0) "RTN","VAFCMSG",74,0) .;Mark entry in pivot file as transmitted "RTN","VAFCMSG",75,0) .D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) "RTN","VAFCMSG",76,0) .;PATCH 530 if locked by check unlock. "RTN","VAFCMSG",77,0) .L -^DPT(DFN) "RTN","VAFCMSG",78,0) ;Done - clean up and quit "RTN","VAFCMSG",79,0) K @INFOARR "RTN","VAFCMSG",80,0) Q "RTN","VAFCMSG",81,0) ; "RTN","VAFCMSG",82,0) BCSTA04 ;Broadcast ADT-A04 messages for all entries in ADT/HL PIVOT file "RTN","VAFCMSG",83,0) ;(#391.71) that have been marked for transmission "RTN","VAFCMSG",84,0) ; "RTN","VAFCMSG",85,0) ;Input : None "RTN","VAFCMSG",86,0) ;Output : None "RTN","VAFCMSG",87,0) ; "RTN","VAFCMSG",88,0) ;Declare variables "RTN","VAFCMSG",89,0) N PIVOTPTR,NODE,DFN,EDITDATE,FIELDS,RESULT "RTN","VAFCMSG",90,0) S PIVOTPTR=0 "RTN","VAFCMSG",91,0) F S PIVOTPTR=+$O(^VAT(391.71,"AXMIT",3,PIVOTPTR)) Q:('PIVOTPTR) D "RTN","VAFCMSG",92,0) .;Bad entry in cross reference - delete it and quit "RTN","VAFCMSG",93,0) .I ('$D(^VAT(391.71,PIVOTPTR))) K ^VAT(391.71,"AXMIT",3,PIVOTPTR) Q "RTN","VAFCMSG",94,0) .;Get event date and pointer to patient "RTN","VAFCMSG",95,0) .S NODE=$G(^VAT(391.71,PIVOTPTR,0)) "RTN","VAFCMSG",96,0) .S FIELDS=$G(^VAT(391.71,PIVOTPTR,2)) "RTN","VAFCMSG",97,0) .S USER=+$P(NODE,"^",9) "RTN","VAFCMSG",98,0) .S EDITDATE=+NODE "RTN","VAFCMSG",99,0) .S DFN=+$P(NODE,"^",3) "RTN","VAFCMSG",100,0) .;PATCH 530 check for locked record - quit if locked. "RTN","VAFCMSG",101,0) .L +^DPT(DFN):1 I '$T Q "RTN","VAFCMSG",102,0) .;Bad pointer to patient - mark entry as transmitted and quit "RTN","VAFCMSG",103,0) .I ('$D(^DPT(DFN,0)))!($G(^DPT(DFN,-9))) D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) Q "RTN","VAFCMSG",104,0) .I $P(^DPT(DFN,0),U)="" D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) Q "RTN","VAFCMSG",105,0) .;**974,Story 841921 (mko): If name components were edited, a bug "RTN","VAFCMSG",106,0) .; in UPDNAME^XLFNAME could allow the .01 to be more than 30 characters. "RTN","VAFCMSG",107,0) .I '$D(^DPT("B",$E($P(^DPT(DFN,0),U),1,30),DFN)) D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) Q "RTN","VAFCMSG",108,0) .;Broadcast ADT-A04 message "RTN","VAFCMSG",109,0) .S RESULT=$$EN^VAFCA04(DFN,EDITDATE,USER,PIVOTPTR) "RTN","VAFCMSG",110,0) .D XMITFLAG^VAFCDD01(PIVOTPTR,"",1) "RTN","VAFCMSG",111,0) .L -^DPT(DFN) "RTN","VAFCMSG",112,0) ;Done - quit "RTN","VAFCMSG",113,0) Q "RTN","VAFCPDT2") 0^3^B40397763^B31881197 "RTN","VAFCPDT2",1,0) VAFCPDT2 ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ;14 Nov 2018 4:20 PM "RTN","VAFCPDT2",2,0) ;;5.3;Registration;**414,505,627,697,797,876,937,944,974**;Aug 13, 1993;Build 2 "RTN","VAFCPDT2",3,0) ;Reference to ^MPIF(984.9,"C" supported by IA #3298 "RTN","VAFCPDT2",4,0) ; "RTN","VAFCPDT2",5,0) CMORHIS ;Find CMOR History "RTN","VAFCPDT2",6,0) I '$O(^DPT(DFN,"MPICMOR",0)) G CMORCHG "RTN","VAFCPDT2",7,0) I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",8,0) .S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",9,0) .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDT2",10,0) D CHISHDR "RTN","VAFCPDT2",11,0) S HIS=0 F S HIS=$O(^DPT(DFN,"MPICMOR",HIS)) Q:'HIS D Q:QFLG "RTN","VAFCPDT2",12,0) .S DIC=2,DR="993",DR(2.0993)=".01;3",DA=DFN,DA(2.0993)=HIS "RTN","VAFCPDT2",13,0) .S DIQ(0)="E",DIQ="CMORNODE" "RTN","VAFCPDT2",14,0) .D EN^DIQ1 K DIC,DR,DA,DIQ "RTN","VAFCPDT2",15,0) .S HISCMOR=$G(CMORNODE(2.0993,HIS,.01,"E")) "RTN","VAFCPDT2",16,0) .I +HISCMOR S HISCMOR=$$GET1^DIQ(4,HISCMOR,.01) "RTN","VAFCPDT2",17,0) .S CHGDT=$G(CMORNODE(2.0993,HIS,3,"E")) "RTN","VAFCPDT2",18,0) .I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",19,0) ..S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",20,0) ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CHISHDR "RTN","VAFCPDT2",21,0) .W !,$P(CHGDT,"@"),?12," - CMOR changed from ",HISCMOR "RTN","VAFCPDT2",22,0) ; "RTN","VAFCPDT2",23,0) CMORCHG ;Find CMOR change request "RTN","VAFCPDT2",24,0) I '$O(^MPIF(984.9,"C",DFN,0)) G EXT "RTN","VAFCPDT2",25,0) I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",26,0) .S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",27,0) .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDT2",28,0) D CCHGHDR "RTN","VAFCPDT2",29,0) S CHG=0 F S CHG=$O(^MPIF(984.9,"C",DFN,CHG)) Q:'CHG D Q:QFLG "RTN","VAFCPDT2",30,0) .S DIC=984.9,DA=CHG,DR=".01;.03;.06;.07;.08;1.03",DIQ="CHGNODE" "RTN","VAFCPDT2",31,0) .S DIQ(0)="EI" D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDT2",32,0) .S CHGNUM=$G(CHGNODE(984.9,CHG,.01,"E")) "RTN","VAFCPDT2",33,0) .S CHGDT=$G(CHGNODE(984.9,CHG,.03,"E")) "RTN","VAFCPDT2",34,0) .S TMSG=$G(CHGNODE(984.9,CHG,.08,"E")) "RTN","VAFCPDT2",35,0) .S TREQ=$G(CHGNODE(984.9,CHG,1.03,"E")) "RTN","VAFCPDT2",36,0) .S SITE=$G(CHGNODE(984.9,CHG,.07,"E")) "RTN","VAFCPDT2",37,0) .S STATUS=$G(CHGNODE(984.9,CHG,.06,"E")) "RTN","VAFCPDT2",38,0) .I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",39,0) ..S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",40,0) ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CCHGHDR "RTN","VAFCPDT2",41,0) .W !,"REQUEST #",CHGNUM," - ",TMSG," ",CHGDT "RTN","VAFCPDT2",42,0) .W !?4,"Type of Request: ",TREQ," ",SITE "RTN","VAFCPDT2",43,0) .W !?4,"Status : ",STATUS,! "RTN","VAFCPDT2",44,0) ; "RTN","VAFCPDT2",45,0) EXT ;Extended patient demographic data "RTN","VAFCPDT2",46,0) I $E(IOST,1,2)="C-" D Q:QFLG "RTN","VAFCPDT2",47,0) .S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",48,0) .W @IOF "RTN","VAFCPDT2",49,0) I QFLG=1 G QUIT^VAFCPDAT "RTN","VAFCPDT2",50,0) W !!,"Additional DPT Data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDT2",51,0) S DA=DFN,DIC=2,DIQ="XDATA",DIQ(0)="EI" "RTN","VAFCPDT2",52,0) ;Story 513046 (elz) place of birth prov and country "RTN","VAFCPDT2",53,0) S DR=".05;.08;.092;.093;.219;.2401;.2402;.2403;.211;.302;.323;.341;.331;.361;1901;.325;.328;.326;.327;.097;.525;391;.0931;.0932" ;**876 - MVI_3432 (cml) "RTN","VAFCPDT2",54,0) N COB,SOB,FNM,MNM,MMNM,NOK,NOKN,DESIG,EMER,ELIG,VET,SRVBR,SRVNUM,SRVEDT,SRVSDT,SRVCPCT,POSRVC,FILEDT,MARS,RELP,POW,NODE,MSD,PATTYPE,POBP,POBC ;**876 - MVI_3432 (cml) "RTN","VAFCPDT2",55,0) D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDT2",56,0) S COB=$G(XDATA(2,DFN,.092,"E")),SOB=$G(XDATA(2,DFN,.093,"E")) "RTN","VAFCPDT2",57,0) S FILEDT=$G(XDATA(2,DFN,.097,"E")),FNM=$G(XDATA(2,DFN,.2401,"E")) "RTN","VAFCPDT2",58,0) S MNM=$G(XDATA(2,DFN,.2402,"E")),MMNM=$G(XDATA(2,DFN,.2403,"E")) "RTN","VAFCPDT2",59,0) S NOK=$G(XDATA(2,DFN,.211,"E")),DESIG=$G(XDATA(2,DFN,.341,"E")) "RTN","VAFCPDT2",60,0) S EMER=$G(XDATA(2,DFN,.331,"E")) "RTN","VAFCPDT2",61,0) S ELIG=$G(XDATA(2,DFN,.361,"E")),VET=$G(XDATA(2,DFN,1901,"E")) "RTN","VAFCPDT2",62,0) S SRVBR=$G(XDATA(2,DFN,.325,"E")),SRVNUM=$G(XDATA(2,DFN,.328,"E")) "RTN","VAFCPDT2",63,0) S SRVEDT=$G(XDATA(2,DFN,.326,"E")),SRVSDT=$G(XDATA(2,DFN,.327,"E")) "RTN","VAFCPDT2",64,0) S MARS=$G(XDATA(2,DFN,.05,"E")),RELP=$G(XDATA(2,DFN,.08,"E")) "RTN","VAFCPDT2",65,0) S POSRVC=$G(XDATA(2,DFN,.323,"E")),SRVCPCT=$G(XDATA(2,DFN,.302,"E")) "RTN","VAFCPDT2",66,0) S NOKN=$G(XDATA(2,DFN,.219,"E")),POW=$G(XDATA(2,DFN,.525,"E")) "RTN","VAFCPDT2",67,0) S PATTYPE=$G(XDATA(2,DFN,391,"E")) ;**876 - MVI_3432 (cml) "RTN","VAFCPDT2",68,0) S POBC=$G(XDATA(2,DFN,.0931,"I")) ;Story 513046 (elz) "RTN","VAFCPDT2",69,0) S POBP=$G(XDATA(2,DFN,.0932,"E")) ;Story 513046 (elz) "RTN","VAFCPDT2",70,0) ; "RTN","VAFCPDT2",71,0) W !,"PLACE OF BIRTH [CITY]",?31,": ",COB "RTN","VAFCPDT2",72,0) W:'$L(POBP) !,"PLACE OF BIRTH [STATE]",?31,": ",SOB "RTN","VAFCPDT2",73,0) W:$L(POBP) !,"PLACE OF BIRTH PROVINCE",?31,": ",POBP ;Story 513046 (elz) "RTN","VAFCPDT2",74,0) W !,"PLACE OF BIRTH COUNTRY",?31,": ",$S(POBC:$$GET1^DIQ(779.004,POBC_",",2),1:"") ; Story 513046 (elz) "RTN","VAFCPDT2",75,0) W !,"FATHER'S NAME",?31,": ",FNM "RTN","VAFCPDT2",76,0) W !,"MOTHER'S NAME",?31,": ",MNM "RTN","VAFCPDT2",77,0) W !,"MOTHER'S MAIDEN NAME",?31,": ",MMNM "RTN","VAFCPDT2",78,0) W !,"NAME OF PRIMARY NEXT OF KIN",?31,": ",NOK "RTN","VAFCPDT2",79,0) W !,"NEXT OF KIN PHONE NUMBER",?31,": ",NOKN "RTN","VAFCPDT2",80,0) W !,"NAME OF DESIGNEE",?31,": ",DESIG "RTN","VAFCPDT2",81,0) W !,"EMERGENCY NAME",?31,": ",EMER "RTN","VAFCPDT2",82,0) W !,"MARITAL STATUS",?31,": ",MARS "RTN","VAFCPDT2",83,0) W !,"RELIGIOUS PREFERENCE",?31,": ",RELP "RTN","VAFCPDT2",84,0) ; "RTN","VAFCPDT2",85,0) D DEM^VADPT "RTN","VAFCPDT2",86,0) ;ETHNICITY info "RTN","VAFCPDT2",87,0) I $G(VADM(11,1)) W !,"ETHNICITY INFORMATION",?31,": ",$P(VADM(11,1),"^",2) "RTN","VAFCPDT2",88,0) ; "RTN","VAFCPDT2",89,0) ;RACE multiple "RTN","VAFCPDT2",90,0) I $O(VADM(12,0)) D "RTN","VAFCPDT2",91,0) .W !,"RACE INFORMATION (multiple):" "RTN","VAFCPDT2",92,0) .S RACEMUL=0 F S RACEMUL=$O(VADM(12,RACEMUL)) Q:'RACEMUL W !?3,$P(VADM(12,RACEMUL),"^",2) "RTN","VAFCPDT2",93,0) ; "RTN","VAFCPDT2",94,0) W !,"PRIMARY ELIGIBILITY CODE",?31,": ",ELIG "RTN","VAFCPDT2",95,0) W !,"PATIENT TYPE",?31,": ",PATTYPE ;**876 - MVI_3432 (cml) "RTN","VAFCPDT2",96,0) W !,"VETERAN (Y/N)?",?31,": ",VET "RTN","VAFCPDT2",97,0) W !,"SERVICE CONNECTED PERCENT",?31,": ",SRVCPCT "RTN","VAFCPDT2",98,0) W !,"PERIOD OF SERVICE",?31,": ",POSRVC "RTN","VAFCPDT2",99,0) W !,"POW STATUS INDICATED?",?31,": ",POW "RTN","VAFCPDT2",100,0) ; "RTN","VAFCPDT2",101,0) ;Military Service Data multiple "RTN","VAFCPDT2",102,0) I $O(^DPT(DFN,.3216,0)) D "RTN","VAFCPDT2",103,0) .W !,"MILITARY SERVICE (multiple):" "RTN","VAFCPDT2",104,0) .W !,"Service Branch Service # Entry DT Separation DT" "RTN","VAFCPDT2",105,0) .W !,"---------------------------------------------------------" "RTN","VAFCPDT2",106,0) .K MSDARR "RTN","VAFCPDT2",107,0) .S MSD=0 F S MSD=$O(^DPT(DFN,.3216,MSD)) Q:'MSD D "RTN","VAFCPDT2",108,0) ..S NODE=^DPT(DFN,.3216,MSD,0) "RTN","VAFCPDT2",109,0) ..S SRVEDT=$P(NODE,"^"),SRVSDT=$P(NODE,"^",2),SRVNUM=$P(NODE,"^",5),SRVBR=$$GET1^DIQ(23,$P(NODE,"^",3),.01) "RTN","VAFCPDT2",110,0) ..S MSDARR(-SRVEDT)=SRVSDT_"^"_SRVNUM_"^"_SRVBR "RTN","VAFCPDT2",111,0) .S SRVEDT="" F S SRVEDT=$O(MSDARR(SRVEDT)) Q:'SRVEDT D "RTN","VAFCPDT2",112,0) ..W !?0,$P(MSDARR(SRVEDT),"^",3),?17,$P(MSDARR(SRVEDT),"^",2),?29,$$FMTE^XLFDT($P(SRVEDT,"-",2)),?44,$$FMTE^XLFDT(+MSDARR(SRVEDT)) "RTN","VAFCPDT2",113,0) ; "RTN","VAFCPDT2",114,0) ;**974,Story 841921 (mko): Name Components "RTN","VAFCPDT2",115,0) N NCIEN "RTN","VAFCPDT2",116,0) S NCIEN=+$P($G(^DPT(DFN,"NAME")),"^") "RTN","VAFCPDT2",117,0) I NCIEN W !,"PATIENT NAME COMPONENTS:" D NC(NCIEN,3,22) "RTN","VAFCPDT2",118,0) ; "RTN","VAFCPDT2",119,0) ;ALIAS multiple "RTN","VAFCPDT2",120,0) I $O(^DPT(DFN,.01,0)) D "RTN","VAFCPDT2",121,0) .W !,"ALIAS (multiple):" "RTN","VAFCPDT2",122,0) .S ALIAS=0 F S ALIAS=$O(^DPT(DFN,.01,ALIAS)) Q:'ALIAS D "RTN","VAFCPDT2",123,0) ..;**974,Story 841921 (mko): Show the entire Alias Name rather than truncating to 30 "RTN","VAFCPDT2",124,0) ..W !?3,$P(^DPT(DFN,.01,ALIAS,0),"^"),?40,"SSN: "_$P($G(^DPT(DFN,.01,ALIAS,0)),"^",2) "RTN","VAFCPDT2",125,0) ..;**974,Story 841921 (mko): Alias Name Components "RTN","VAFCPDT2",126,0) ..D NC(+$P($G(^DPT(DFN,.01,ALIAS,0)),"^",3),6,25) "RTN","VAFCPDT2",127,0) ; "RTN","VAFCPDT2",128,0) ; Preferred Name "RTN","VAFCPDT2",129,0) I $G(DNODE(2,DFN,.2405,"E"))]"" W !,"PREFERRED NAME",?31,": ",DNODE(2,DFN,.2405,"E") "RTN","VAFCPDT2",130,0) ; "RTN","VAFCPDT2",131,0) W !,"DATE ENTERED IN PATIENT FILE",?31,": ",FILEDT "RTN","VAFCPDT2",132,0) ; "RTN","VAFCPDT2",133,0) K ALIAS,XDATA,CHG,CHGNUM,CHGDT,TMSG,TREQ,SITE,STATUS,HIS,HISCMOR,CMORNODE,CHGNODE,RACEMUL,VADM,MSDARR "RTN","VAFCPDT2",134,0) Q "RTN","VAFCPDT2",135,0) ; "RTN","VAFCPDT2",136,0) NC(NCIEN,TAB1,TAB2) ;**974,Story 841921 (mko): Get and write Name Components "RTN","VAFCPDT2",137,0) Q:'$G(NCIEN) "RTN","VAFCPDT2",138,0) S TAB1="?"_+$G(TAB1),TAB2="?"_+$G(TAB2) "RTN","VAFCPDT2",139,0) N DIERR,DIHELP,DIMSG,NC,NCIENS,TARG,MSG "RTN","VAFCPDT2",140,0) S NCIENS=NCIEN_"," "RTN","VAFCPDT2",141,0) D GETS^DIQ(20,NCIENS,"1;2;3;5","I","TARG","MSG") Q:$D(DIERR) "RTN","VAFCPDT2",142,0) S NC=$G(TARG(20,NCIENS,1,"I")) W:NC]"" !,@TAB1,"Family (Last) Name",@TAB2,": "_NC "RTN","VAFCPDT2",143,0) S NC=$G(TARG(20,NCIENS,2,"I")) W:NC]"" !,@TAB1,"Given (First) Name",@TAB2,": "_NC "RTN","VAFCPDT2",144,0) S NC=$G(TARG(20,NCIENS,3,"I")) W:NC]"" !,@TAB1,"Middle Name",@TAB2,": "_NC "RTN","VAFCPDT2",145,0) S NC=$G(TARG(20,NCIENS,5,"I")) W:NC]"" !,@TAB1,"Suffix",@TAB2,": "_NC "RTN","VAFCPDT2",146,0) Q "RTN","VAFCPDT2",147,0) ; "RTN","VAFCPDT2",148,0) CHISHDR W !!,"CMOR History:",!,"--------------" "RTN","VAFCPDT2",149,0) Q "RTN","VAFCPDT2",150,0) CCHGHDR W !!,"CMOR Change Request History:",!,"----------------------------" "RTN","VAFCPDT2",151,0) Q "RTN","VAFCPTED") 0^4^B45940753^B15564397 "RTN","VAFCPTED",1,0) VAFCPTED ;ISA/RJS,Zoltan-EDIT EXISTING PATIENT ;11 Dec 2018 3:59 PM "RTN","VAFCPTED",2,0) ;;5.3;Registration;**149,333,756,837,974**;Aug 13, 1993;Build 2 "RTN","VAFCPTED",3,0) EDIT(DGDFN,ARRAY,STRNGDR) ;-- Edits existing patient "RTN","VAFCPTED",4,0) ;Input: "RTN","VAFCPTED",5,0) ; DGDFN - IEN in the PATIENT (#2) file "RTN","VAFCPTED",6,0) ; ARRAY - Array containing fields to be edited. "RTN","VAFCPTED",7,0) ; Ex. ARRAY(.111)="123 STREET" or ARRAY(2,.111)="123... "RTN","VAFCPTED",8,0) ; STRNGDR - String of delimited PATIENT (#2) file fields in the order "RTN","VAFCPTED",9,0) ; in which the fields will be processed by DIE. "RTN","VAFCPTED",10,0) ; Ex. ".01;.03;.05..." "RTN","VAFCPTED",11,0) ;Output: "RTN","VAFCPTED",12,0) ; No output "RTN","VAFCPTED",13,0) ; "RTN","VAFCPTED",14,0) S U="^" "RTN","VAFCPTED",15,0) N LOCKFLE,FLD,ZTQUEUED,DIQUIET,OLDZIP,VAFCX,STRNG "RTN","VAFCPTED",16,0) S (ZTQUEUED,DIQUIET)=1 "RTN","VAFCPTED",17,0) L +^DPT(DGDFN):60 "RTN","VAFCPTED",18,0) S LOCKFLE=$T ; Need to remember whether the lock went through. "RTN","VAFCPTED",19,0) I $L($G(@ARRAY@(.1112)))=5 D "RTN","VAFCPTED",20,0) . ; This section prevents a 5-digit ZIP from replacing "RTN","VAFCPTED",21,0) . ; an otherwise equivalent ZIP+4. "RTN","VAFCPTED",22,0) . S OLDZIP=$$GET1^DIQ(2,DGDFN_",",.1112,"I") "RTN","VAFCPTED",23,0) . I $E(OLDZIP,1,5)=@ARRAY@(.1112) S @ARRAY@(.1112)=OLDZIP "RTN","VAFCPTED",24,0) ;process the given PATIENT file DR string in the given order "RTN","VAFCPTED",25,0) S STRNG=STRNGDR F VAFCX=1:1 Q:STRNG="" S FLD=$P(STRNGDR,";",VAFCX) S STRNG=$P(STRNGDR,";",VAFCX+1,$L(STRNGDR,";")) D LOAD "RTN","VAFCPTED",26,0) ; "RTN","VAFCPTED",27,0) ; **837, MVI_882 start "RTN","VAFCPTED",28,0) S FLD("TEMP")="" "RTN","VAFCPTED",29,0) F S FLD("TEMP")=$O(@ARRAY@(FLD("TEMP"))) Q:'FLD("TEMP") D "RTN","VAFCPTED",30,0) . I $G(@ARRAY@(FLD("TEMP")))]"",STRNGDR'[FLD("TEMP") D "RTN","VAFCPTED",31,0) . ; update TIN and/or FIN if it is missing in variable STRNGDR "RTN","VAFCPTED",32,0) . I FLD("TEMP")=991.08!(FLD("TEMP")=991.09) S FLD=FLD("TEMP") D LOAD "RTN","VAFCPTED",33,0) ; **837, MVI_882 end "RTN","VAFCPTED",34,0) ;Do Address Bulletin if incoming Address does not equal existing "RTN","VAFCPTED",35,0) ;Address - removed bulletin with patch DG*5.3*333 "RTN","VAFCPTED",36,0) ; "RTN","VAFCPTED",37,0) ;I $D(@ARRAY@(.111))!$D(@ARRAY@(.112))!$D(@ARRAY@(.113))!$D(@ARRAY@(.114))!$D(@ARRAY@(.115))!$D(@ARRAY@(.117))!$D(@ARRAY@(.1112)) D ;**333 "RTN","VAFCPTED",38,0) ;. D ADDRESS^RGRSBULL(DGDFN,$G(@ARRAY@(.01)),$G(@ARRAY@(.111)),$G(@ARRAY@(.112)),$G(@ARRAY@(.113)),@ARRAY@("SENDING SITE"),$G(@ARRAY@(.114)),$G(@ARRAY@(.117)),$G(@ARRAY@(.115)),$G(@ARRAY@(.1112))) "RTN","VAFCPTED",39,0) ; "RTN","VAFCPTED",40,0) I LOCKFLE L -^DPT(DGDFN) "RTN","VAFCPTED",41,0) ; "RTN","VAFCPTED",42,0) K DIE,DA "RTN","VAFCPTED",43,0) Q "RTN","VAFCPTED",44,0) ; "RTN","VAFCPTED",45,0) LOAD ; -- Loads fields to patient file "RTN","VAFCPTED",46,0) N DR,DIE "RTN","VAFCPTED",47,0) ;**756 check if updating ALIAS "RTN","VAFCPTED",48,0) I FLD=1 D Q "RTN","VAFCPTED",49,0) . ;**974,Story 841921 (mko): If flag is not set, compare and update the Alias .01; "RTN","VAFCPTED",50,0) . ; If the flag is set, compare and update the Alias Name Components "RTN","VAFCPTED",51,0) . I '$$GETFLAG D ALIAS Q "RTN","VAFCPTED",52,0) . D ALIASNC(ARRAY,DGDFN,.RGER) "RTN","VAFCPTED",53,0) ;**974,Story 841921 (mko): File name components "RTN","VAFCPTED",54,0) I FLD=1.01 D Q "RTN","VAFCPTED",55,0) . N NAME "RTN","VAFCPTED",56,0) . M NAME=@ARRAY@(1.01) "RTN","VAFCPTED",57,0) . D UPDNC(DGDFN,.NAME) "RTN","VAFCPTED",58,0) S DA=DGDFN,DIE="^DPT(" "RTN","VAFCPTED",59,0) I $G(@ARRAY@(FLD))="" Q "RTN","VAFCPTED",60,0) I $G(@ARRAY@(FLD))["@" S @ARRAY@(FLD)="@" "RTN","VAFCPTED",61,0) ;GENERATE BULLETIN FOR CONDITION BELOW ? "RTN","VAFCPTED",62,0) I $G(@ARRAY@(FLD))[U Q "RTN","VAFCPTED",63,0) S DR=FLD_"///^S X=$G(@ARRAY@(FLD))" "RTN","VAFCPTED",64,0) D ^DIE "RTN","VAFCPTED",65,0) Q "RTN","VAFCPTED",66,0) ; "RTN","VAFCPTED",67,0) UPDNC(DGDFN,NAME) ; "RTN","VAFCPTED",68,0) N FDA,IEN,MSG,DIERR "RTN","VAFCPTED",69,0) ;Call updater to add or edit entry in Name Component file "RTN","VAFCPTED",70,0) S FDA(20,"?+1,",.01)=2 "RTN","VAFCPTED",71,0) S FDA(20,"?+1,",.02)=.01 "RTN","VAFCPTED",72,0) S FDA(20,"?+1,",.03)=DGDFN_"," "RTN","VAFCPTED",73,0) S:$D(NAME("FAMILY"))#2 FDA(20,"?+1,",1)=NAME("FAMILY") "RTN","VAFCPTED",74,0) S:$D(NAME("GIVEN"))#2 FDA(20,"?+1,",2)=NAME("GIVEN") "RTN","VAFCPTED",75,0) S:$D(NAME("MIDDLE"))#2 FDA(20,"?+1,",3)=NAME("MIDDLE") "RTN","VAFCPTED",76,0) S:$D(NAME("SUFFIX"))#2 FDA(20,"?+1,",5)=NAME("SUFFIX") "RTN","VAFCPTED",77,0) D UPDATE^DIE("K","FDA","IEN","MSG") "RTN","VAFCPTED",78,0) Q "RTN","VAFCPTED",79,0) ; "RTN","VAFCPTED",80,0) ALIAS ; update Alias multiple **756 "RTN","VAFCPTED",81,0) ;allow the synchronizing of the Alias multiple with the data passed in the array "RTN","VAFCPTED",82,0) ;array(1,x)=name (last, first middle suffix format)^ssn "RTN","VAFCPTED",83,0) N HAVE,I,MIEN,ADD,DONE,FDA,MPIFERR,DEL,ALIAS,CNT,DGALIAS "RTN","VAFCPTED",84,0) M HAVE=^DPT(DGDFN,.01) "RTN","VAFCPTED",85,0) S CNT=0 "RTN","VAFCPTED",86,0) ;see if any need to be added "RTN","VAFCPTED",87,0) S I=0 F S I=$O(@ARRAY@(1,I)) Q:'I D ;loop through incoming data "RTN","VAFCPTED",88,0) .S ADD=1,(DONE,MIEN)=0 F S MIEN=$O(HAVE(MIEN)) Q:'MIEN D I DONE Q ;loop through existing data "RTN","VAFCPTED",89,0) ..I $P(@ARRAY@(1,I),"^",1,2)=$P($G(HAVE(MIEN,0)),"^",1,2) S ADD=0,DONE=1 Q ;compare to existing data to see if already in subfile, if not then "RTN","VAFCPTED",90,0) .I ADD S ALIAS=@ARRAY@(1,I) D ;add new entry to subfile "RTN","VAFCPTED",91,0) ..S FDA(2.01,"+"_I_","_DGDFN_",",.01)=$P(@ARRAY@(1,I),"^") "RTN","VAFCPTED",92,0) ..S FDA(2.01,"+"_I_","_DGDFN_",",1)=$P(@ARRAY@(1,I),"^",2) "RTN","VAFCPTED",93,0) I $D(FDA) D UPDATE^DIE("E","FDA",,"MPIFERR") I $G(MPIFERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_MPIFERR("DIERR",1,"TEXT",1) "RTN","VAFCPTED",94,0) ;delete entries "RTN","VAFCPTED",95,0) K FDA,MPIFERR "RTN","VAFCPTED",96,0) S MIEN=0 F S MIEN=$O(HAVE(MIEN)) Q:'MIEN D ;loop through existing data "RTN","VAFCPTED",97,0) . ; **837,MVI_805 check for duplicates (name + ssn combination) "RTN","VAFCPTED",98,0) . S HAVE=$P($G(HAVE(MIEN,0)),"^",1,2) "RTN","VAFCPTED",99,0) . X $S(HAVE="":"",$D(DGALIAS(HAVE)):"S FDA(2.01,MIEN_"",""_DGDFN_"","",.01)=""@"" Q",1:"S DGALIAS(HAVE)=HAVE") "RTN","VAFCPTED",100,0) . ; "RTN","VAFCPTED",101,0) . S DEL=1,(DONE,I)=0 F S I=$O(@ARRAY@(1,I)) Q:'I D I DONE Q ;loop through incoming data "RTN","VAFCPTED",102,0) . . I HAVE=$P(@ARRAY@(1,I),"^",1,2) S DEL=0,DONE=1 Q ;compare to existing data to see if data should be deleted "RTN","VAFCPTED",103,0) . I DEL S FDA(2.01,MIEN_","_DGDFN_",",.01)="@" ;existing entry to delete "RTN","VAFCPTED",104,0) I $D(FDA) D FILE^DIE("E","FDA","MPIERR") I $G(MPIFERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_MPIFERR("DIERR",1,"TEXT",1) ;delete entry "RTN","VAFCPTED",105,0) Q "RTN","VAFCPTED",106,0) ; "RTN","VAFCPTED",107,0) ALIASNC(ARRAY,DGDFN,RGER) ;Compare incoming Alias Name Components with existing Alias Name Components and add or delete as necessary "RTN","VAFCPTED",108,0) ;**974,Story 841921 (mko): New subroutine "RTN","VAFCPTED",109,0) N FDA,HAVE,IEN,IENROOT,IN,NC,NCIEN,NCIENS,ORIG,SEQ,SUB "RTN","VAFCPTED",110,0) ; "RTN","VAFCPTED",111,0) ;Create IN("surname^firstname^middlename^suffix^ssn",seq#)="" from incoming data "RTN","VAFCPTED",112,0) S SEQ=0 F S SEQ=$O(@ARRAY@(1,SEQ)) Q:'SEQ D "RTN","VAFCPTED",113,0) . S IN(@ARRAY@(1,SEQ,"NC")_"^"_$P(@ARRAY@(1,SEQ),"^",2),SEQ)="" "RTN","VAFCPTED",114,0) ; "RTN","VAFCPTED",115,0) ;Create ORIG("surname^firstname^middlename^suffix^ssn",subien)="" from existing data "RTN","VAFCPTED",116,0) M HAVE=^DPT(DGDFN,.01) "RTN","VAFCPTED",117,0) S IEN=0 F S IEN=$O(HAVE(IEN)) Q:'IEN D "RTN","VAFCPTED",118,0) . S NCIEN=$P(HAVE(IEN,0),"^",3) "RTN","VAFCPTED",119,0) . D:$P(HAVE(IEN,0),"^",3)>0 "RTN","VAFCPTED",120,0) .. S NC=$G(^VA(20,NCIEN,1)) "RTN","VAFCPTED",121,0) .. S SUB=$P(NC,"^",1,3)_"^"_$P(NC,"^",5)_"^"_$P(HAVE(IEN,0),"^",2) "RTN","VAFCPTED",122,0) .. ;If this is a duplicate, set the FDA for deletion here "RTN","VAFCPTED",123,0) .. S:$D(ORIG(SUB)) FDA(2.01,IEN_","_DGDFN_",",.01)="@" "RTN","VAFCPTED",124,0) .. S ORIG(SUB,IEN)="" "RTN","VAFCPTED",125,0) ; "RTN","VAFCPTED",126,0) ;Loop through ORIG to delete Aliases that aren't in IN array "RTN","VAFCPTED",127,0) S SUB="" F S SUB=$O(ORIG(SUB)) Q:SUB="" D "RTN","VAFCPTED",128,0) . D:'$D(IN(SUB)) "RTN","VAFCPTED",129,0) .. S IEN=$O(ORIG(SUB,0)) Q:'IEN "RTN","VAFCPTED",130,0) .. S FDA(2.01,IEN_","_DGDFN_",",.01)="@" "RTN","VAFCPTED",131,0) D:$D(FDA) "RTN","VAFCPTED",132,0) . D FILE^DIE("E","FDA","MSG") K FDA "RTN","VAFCPTED",133,0) . I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG "RTN","VAFCPTED",134,0) ; "RTN","VAFCPTED",135,0) ;Loop through IN and add Aliases that aren't in ORIG array; we need to add the Alias, before the Name Components entry can be updated "RTN","VAFCPTED",136,0) S SUB="" F S SUB=$O(IN(SUB)) Q:SUB="" D "RTN","VAFCPTED",137,0) . D:'$D(ORIG(SUB)) "RTN","VAFCPTED",138,0) .. S SEQ=$O(IN(SUB,0)) "RTN","VAFCPTED",139,0) .. S FDA(2.01,"+"_SEQ_","_DGDFN_",",.01)=$$FMTNAME(@ARRAY@(1,SEQ,"NC")) "RTN","VAFCPTED",140,0) .. S FDA(2.01,"+"_SEQ_","_DGDFN_",",1)=$P(@ARRAY@(1,SEQ),"^",2) "RTN","VAFCPTED",141,0) D:$D(FDA) "RTN","VAFCPTED",142,0) . ;Add the Alias and Alias SSN "RTN","VAFCPTED",143,0) . D UPDATE^DIE("E","FDA","IENROOT","MSG") K FDA "RTN","VAFCPTED",144,0) . I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG "RTN","VAFCPTED",145,0) . ;For each Alias added, update the corresponding Name Components entry "RTN","VAFCPTED",146,0) . S SEQ=0 F S SEQ=$O(IENROOT(SEQ)) Q:'SEQ D "RTN","VAFCPTED",147,0) .. S IEN=$G(IENROOT(SEQ)) Q:IEN'>0 "RTN","VAFCPTED",148,0) .. S NCIENS=$P($G(^DPT(DGDFN,.01,IEN,0)),"^",3)_"," Q:'NCIENS "RTN","VAFCPTED",149,0) .. S NC=$G(@ARRAY@(1,SEQ,"NC")) "RTN","VAFCPTED",150,0) .. S FDA(20,NCIENS,1)=$P(NC,"^") "RTN","VAFCPTED",151,0) .. S FDA(20,NCIENS,2)=$P(NC,"^",2) "RTN","VAFCPTED",152,0) .. S FDA(20,NCIENS,3)=$P(NC,"^",3) "RTN","VAFCPTED",153,0) .. S FDA(20,NCIENS,5)=$P(NC,"^",4) "RTN","VAFCPTED",154,0) .. D FILE^DIE("E","FDA","MSG") K FDA "RTN","VAFCPTED",155,0) .. I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG "RTN","VAFCPTED",156,0) Q "RTN","VAFCPTED",157,0) ; "RTN","VAFCPTED",158,0) BLDERR(MSGROOT) ;Build an error from the error message array "RTN","VAFCPTED",159,0) ;**974,Story 841921 (mko): New subroutine "RTN","VAFCPTED",160,0) N ERRARR,ERRMSG,I "RTN","VAFCPTED",161,0) D MSG^DIALOG("AE",.ERRARR,"","",MSGROOT) "RTN","VAFCPTED",162,0) S ERRMSG="",I=0 F S I=$O(ERRARR(I)) Q:'I S ERRMSG=ERRMSG_$S(ERRMSG]"":" ",1:"")_$G(ERRARR(I)) "RTN","VAFCPTED",163,0) Q ERRMSG "RTN","VAFCPTED",164,0) ; "RTN","VAFCPTED",165,0) FMTNAME(ARRAY,LEN) ;Return a formatted name from cleaned Name Components that doesn't exceed LEN characters in length. "RTN","VAFCPTED",166,0) ;**974,Story 841921 (mko): New function (duplicate of FMTNAME^RGADTP3) "RTN","VAFCPTED",167,0) N NC "RTN","VAFCPTED",168,0) S:'$G(LEN) LEN=30 "RTN","VAFCPTED",169,0) ; "RTN","VAFCPTED",170,0) ;If ARRAY is passed as a string and doesn't have descendants assume it equals "surname^first^middle^suffix" "RTN","VAFCPTED",171,0) D:$D(ARRAY)=1 "RTN","VAFCPTED",172,0) . S ARRAY("SURNAME")=$P(ARRAY,"^") "RTN","VAFCPTED",173,0) . S ARRAY("FIRST")=$P(ARRAY,"^",2) "RTN","VAFCPTED",174,0) . S ARRAY("MIDDLE")=$P(ARRAY,"^",3) "RTN","VAFCPTED",175,0) . S ARRAY("SUFFIX")=$P(ARRAY,"^",4) "RTN","VAFCPTED",176,0) ; "RTN","VAFCPTED",177,0) ;Clean the components "RTN","VAFCPTED",178,0) S NC("FAMILY")=$$CLEANC^XLFNAME($G(ARRAY("SURNAME"))) "RTN","VAFCPTED",179,0) S NC("GIVEN")=$$CLEANC^XLFNAME($G(ARRAY("FIRST"))) "RTN","VAFCPTED",180,0) S NC("MIDDLE")=$$CLEANC^XLFNAME($G(ARRAY("MIDDLE"))) "RTN","VAFCPTED",181,0) S NC("SUFFIX")=$$CLEANC^XLFNAME($G(ARRAY("SUFFIX"))) "RTN","VAFCPTED",182,0) ; "RTN","VAFCPTED",183,0) ;Build a full name, maximum length LEN "RTN","VAFCPTED",184,0) Q $$NAMEFMT^XLFNAME(.NC,"F","CL"_LEN) "RTN","VAFCPTED",185,0) ; "RTN","VAFCPTED",186,0) GETFLAG() ;Get the value of the name components flag "RTN","VAFCPTED",187,0) ;;**974,Story 841921 (mko): New function "RTN","VAFCPTED",188,0) I $T(GETFLAG^MPIFNAMC)]"" Q $$GETFLAG^MPIFNAMC "RTN","VAFCPTED",189,0) Q 0 "RTN","VAFCQRY1") 0^5^B93833983^B86325384 "RTN","VAFCQRY1",1,0) VAFCQRY1 ;BIR/DLR-Query for patient demographics ;3 Dec 2018 12:56 PM "RTN","VAFCQRY1",2,0) ;;5.3;Registration;**428,474,477,575,627,648,698,711,707,837,874,937,974**;Aug 13, 1993;Build 2 "RTN","VAFCQRY1",3,0) ; "RTN","VAFCQRY1",4,0) ;Reference to $$GETDFNS^MPIF002 supported by IA #3634. "RTN","VAFCQRY1",5,0) ; "RTN","VAFCQRY1",6,0) BLDPID(DFN,CNT,SEQ,PID,HL,ERR) ;build PID from File #2 "RTN","VAFCQRY1",7,0) ; Variable list "RTN","VAFCQRY1",8,0) ; DFN - internal PATIENT (#2) number "RTN","VAFCQRY1",9,0) ; CNT - value to be place in PID seq#1 (SET ID) "RTN","VAFCQRY1",10,0) ; SEQ - variable consisting of sequence numbers delimited by commas "RTN","VAFCQRY1",11,0) ; that will be used to build the message (default is ALL) "RTN","VAFCQRY1",12,0) ; PID (passed by reference) - array location to place PID segment "RTN","VAFCQRY1",13,0) ; result, the array can have existing values when passed. "RTN","VAFCQRY1",14,0) ; HL - array that contains the necessary HL variables (init^hlsub) "RTN","VAFCQRY1",15,0) ; ERR - array that is used to return an error "RTN","VAFCQRY1",16,0) ; "RTN","VAFCQRY1",17,0) N VAFCMN,VAFCMMN,SITE,VAFCZN,SSN,SITE,APID,HIST,HISTDT,VAFCHMN,NXT,NXTC,COMP,REP,SUBCOMP,STATE,CITY,CLAIM,HLECH,HLFS,HLQ,STATEIEN,SARY,LVL,LNGTH,X,STN,SITA,HLES "RTN","VAFCQRY1",18,0) I '$D(SEQ) S SEQ="ALL" "RTN","VAFCQRY1",19,0) I SEQ="" S SEQ="ALL" "RTN","VAFCQRY1",20,0) I SEQ'="ALL" D "RTN","VAFCQRY1",21,0) .; setting up temp array to hold fields to be included in message "RTN","VAFCQRY1",22,0) .N POS,EN S POS=1 F S EN=$P(SEQ,",",POS) Q:EN="" S SARY(EN)="",POS=POS+1 "RTN","VAFCQRY1",23,0) S HLECH=HL("ECH"),HLFS=HL("FS"),HLQ=HL("Q"),(COMP,HL("COMP"))=$E(HL("ECH"),1) "RTN","VAFCQRY1",24,0) S (SUBCOMP,HL("SUBCOMP"))=$E(HL("ECH"),4),(REP,HL("REP"))=$E(HL("ECH"),2),HLES=$E(HL("ECH"),3) "RTN","VAFCQRY1",25,0) ;get Patient File MPI node "RTN","VAFCQRY1",26,0) S VAFCMN="" "RTN","VAFCQRY1",27,0) N X S X="MPIFAPI" X ^%ZOSF("TEST") I $T S VAFCMN=$$MPINODE^MPIFAPI(DFN) "RTN","VAFCQRY1",28,0) I +VAFCMN<0 S VAFCMN="" "RTN","VAFCQRY1",29,0) S VAFCZN=^DPT(DFN,0),SSN=$P(^DPT(DFN,0),"^",9) "RTN","VAFCQRY1",30,0) ;**974,Story 841921 (mko): Get the internal Alias values instead of external "RTN","VAFCQRY1",31,0) ; so that the internal pointer (IEN) of the Name Components entry can be retrieved. "RTN","VAFCQRY1",32,0) ; In the following code, values are obtained from the "I" nodes instead of the "E" nodes. "RTN","VAFCQRY1",33,0) N VAFCA,VAFCA1 D GETS^DIQ(2,DFN_",","1*","I","VAFCA") ;**698 GETTING ALIAS INFO "RTN","VAFCQRY1",34,0) ;** 707 reformat alias information to include ALIAS SSN in PID-3 with a location reference to the name in PID-5 "RTN","VAFCQRY1",35,0) I $D(VAFCA) N CT,ENT S CT=0,ENT="" F S ENT=$O(VAFCA(2.01,ENT)) Q:ENT="" D "RTN","VAFCQRY1",36,0) .S CT=CT+1 "RTN","VAFCQRY1",37,0) .S VAFCA1(CT,"NAME")=$G(VAFCA(2.01,ENT,.01,"I")) "RTN","VAFCQRY1",38,0) .;I $G(VAFCA(2.01,ENT,1,"E"))'="" S VAFCA1("SSN")="",VAFCA1(CT,"SSN")=$G(VAFCA(2.01,ENT,1,"E")) "RTN","VAFCQRY1",39,0) .S VAFCA1(CT,"SSN")=$G(VAFCA(2.01,ENT,1,"I")) "RTN","VAFCQRY1",40,0) .S VAFCA1(CT,"NCIEN")=$G(VAFCA(2.01,ENT,100.03,"I"))_"^"_ENT ;**974,Story 841921 (mko): Get Name Components pointer and save IENS of Alias subentry "RTN","VAFCQRY1",41,0) S SITE=$$SITE^VASITE,STN=$P($$SITE^VASITE,"^",3) "RTN","VAFCQRY1",42,0) N TMP F TMP=1:1:31 S APID(TMP)="" "RTN","VAFCQRY1",43,0) S APID(2)=CNT "RTN","VAFCQRY1",44,0) ;list of fields used for backwards compatibility with HDR "RTN","VAFCQRY1",45,0) I $D(SARY(2))!(SEQ="ALL") I VAFCMN'="" S APID(3)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2) ;Patient ID "RTN","VAFCQRY1",46,0) ;repeat patient ID list including ICN (NI),SSN (SS),CLAIM# (PN) and DFN (PI) "RTN","VAFCQRY1",47,0) I $D(SARY(3))!(SEQ="ALL") D "RTN","VAFCQRY1",48,0) .S APID(4)="" "RTN","VAFCQRY1",49,0) .;National Identifier (ICN) "RTN","VAFCQRY1",50,0) .I VAFCMN'="",+VAFCMN>0 D "RTN","VAFCQRY1",51,0) ..I $E($P(VAFCMN,"^"),1,3)=STN S SITA=STN "RTN","VAFCQRY1",52,0) ..I $E($P(VAFCMN,"^"),1,3)'=STN S SITA="200M" ; **707 update assigning authority for national ICNs to 200M for MPI "RTN","VAFCQRY1",53,0) ..S APID(4)=$P(VAFCMN,"^")_"V"_$P(VAFCMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L" D "RTN","VAFCQRY1",54,0) ..;Assumption that if this is a local ICN at this point send the message with an expiration date of today, so that it will be treated as a deprecated ID and stored on the MPI as such "RTN","VAFCQRY1",55,0) ..I $E($P(VAFCMN,"^"),1,3)=$P($$SITE^VASITE,"^",3) S APID(4)=APID(4)_COMP_COMP_$$HLDATE^HLFNC(DT,"DT") ;**707 TO ONLY SEND DATE NO TIME "RTN","VAFCQRY1",56,0) .I $G(SSN)'="" S APID(4)=APID(4)_$S(APID(4)'="":REP,1:"")_SSN_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L" "RTN","VAFCQRY1",57,0) .S NXTC=0,LVL=0 ;**837,MVI_879: Move here, so that LVL gets set before pulling in TIN and FIN "RTN","VAFCQRY1",58,0) .;**837,MVI_879: Get TIN and FIN from Patient file and put in PID-3 "RTN","VAFCQRY1",59,0) .N TIN,FIN,REF "RTN","VAFCQRY1",60,0) .S TIN=$P(VAFCMN,"^",8),FIN=$P(VAFCMN,"^",9),REF=$NA(APID(4)) "RTN","VAFCQRY1",61,0) .D ADDLINE($S(TIN="":HLQ,1:TIN)_COMP_COMP_COMP_"USDOD"_SUBCOMP_SUBCOMP_"0363"_COMP_"TIN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L",.LVL,REF,REP) "RTN","VAFCQRY1",62,0) .D ADDLINE($S(FIN="":HLQ,1:FIN)_COMP_COMP_COMP_"USDOD"_SUBCOMP_SUBCOMP_"0363"_COMP_"FIN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L",.LVL,REF,REP) "RTN","VAFCQRY1",63,0) .I $G(DFN)'="" D "RTN","VAFCQRY1",64,0) ..D ADDLINE(DFN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L",.LVL,REF,REP) "RTN","VAFCQRY1",65,0) ..;CLAIM# **707 moved dfn and claim number up here since Alias SSN could be many "RTN","VAFCQRY1",66,0) ..I $D(^DPT(DFN,.31)) S CLAIM=$P(^DPT(DFN,.31),"^",3) I +CLAIM>0 D ADDLINE(CLAIM_COMP_COMP_COMP_"USVBA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PN"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L",.LVL,REF,REP) "RTN","VAFCQRY1",67,0) .I $D(VAFCA1) D "RTN","VAFCQRY1",68,0) ..;Have Alias SSNs "RTN","VAFCQRY1",69,0) ..S CT=0 F S CT=$O(VAFCA1(CT)) Q:+CT<1 D "RTN","VAFCQRY1",70,0) ...S NXT=$S($G(VAFCA1(CT,"SSN"))="":HL("Q"),1:$G(VAFCA1(CT,"SSN")))_COMP_COMP_COMP_"USSSA"_SUBCOMP_SUBCOMP_"0363"_COMP_"SS"_COMP_"VA FACILITY ID"_SUBCOMP_$$STA^XUAF4(+SITE)_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(DT,"DT") "RTN","VAFCQRY1",71,0) ...I LVL=0 D "RTN","VAFCQRY1",72,0) ....I $L(APID(4)_NXT)'>244 S APID(4)=APID(4)_REP_NXT Q "RTN","VAFCQRY1",73,0) ....I $L(APID(4)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(4)),APID(4)=APID(4)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),NXTC=1 "RTN","VAFCQRY1",74,0) ...I LVL>0 D "RTN","VAFCQRY1",75,0) ....I $L($G(APID(4,LVL))_NXT)'>245 S APID(4,LVL)=$G(APID(4,LVL))_$S(NXTC=0:REP,1:"")_NXT Q "RTN","VAFCQRY1",76,0) ....I $L($G(APID(4,LVL))_NXT)>245 S LNGTH=244-$L(APID(4,LVL)),APID(4,LVL)=APID(4,LVL)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(4,LVL)=NXT "RTN","VAFCQRY1",77,0) ...I NXTC=1 S NXTC=0 "RTN","VAFCQRY1",78,0) .I $D(^DPT(DFN,"MPIFHIS")) N HIST S HIST=0 F S HIST=$O(^DPT(DFN,"MPIFHIS",HIST)) Q:'HIST S VAFCHMN=^DPT(DFN,"MPIFHIS",HIST,0) S HISTDT=$P(VAFCHMN,"^",4) D "RTN","VAFCQRY1",79,0) ..;**477 due to a timing issue if checksum and D/T of deprication of ICN is not present hang two seconds and try again if still not able to get ICN set D/T to DT "RTN","VAFCQRY1",80,0) ..I $G(HISTDT)="" H 2 S VAFCHMN=^DPT(DFN,"MPIFHIS",HIST,0) S HISTDT=$P(VAFCHMN,"^",4) I HISTDT="" S HISTDT=DT "RTN","VAFCQRY1",81,0) ..I APID(4)'="" D "RTN","VAFCQRY1",82,0) ...I $E($P(VAFCHMN,"^"),1,3)=STN S SITA=STN "RTN","VAFCQRY1",83,0) ...I $E($P(VAFCHMN,"^"),1,3)'=STN S SITA="200M" ; **707 update assigning authority for national ICNs to 200M for MPI "RTN","VAFCQRY1",84,0) ...S NXT=$P(VAFCHMN,"^")_"V"_$P(VAFCHMN,"^",2)_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(HISTDT,"DT") ;**648 only send date not time "RTN","VAFCQRY1",85,0) ...I LVL=0 D "RTN","VAFCQRY1",86,0) ....I $L(APID(4)_NXT)'>244 S APID(4)=APID(4)_REP_NXT Q "RTN","VAFCQRY1",87,0) ....I $L(APID(4)_NXT)>244 S LVL=1 S LNGTH=244-$L(APID(4)),APID(4)=APID(4)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)),NXTC=1 "RTN","VAFCQRY1",88,0) ...I LVL>0 D "RTN","VAFCQRY1",89,0) ....I $L($G(APID(4,LVL))_NXT)'>245 S APID(4,LVL)=$G(APID(4,LVL))_$S(NXTC=0:REP,1:"")_NXT Q "RTN","VAFCQRY1",90,0) ....I $L($G(APID(4,LVL))_NXT)>245 S LNGTH=244-$L(APID(4,LVL)),APID(4,LVL)=APID(4,LVL)_REP_$E(NXT,1,LNGTH) S LNGTH=LNGTH+1,NXT=$E(NXT,LNGTH,$L(NXT)) S LVL=LVL+1 S APID(4,LVL)=NXT "RTN","VAFCQRY1",91,0) ..I NXTC=1 S NXTC=0 "RTN","VAFCQRY1",92,0) ..I APID(4)="" D "RTN","VAFCQRY1",93,0) ...I $E($P(VAFCHMN,"^"),1,3)=STN S SITA=STN "RTN","VAFCQRY1",94,0) ...I $E($P(VAFCHMN,"^"),1,3)'=STN S SITA="200M" "RTN","VAFCQRY1",95,0) ...S APID(4)=$P(VAFCHMN,"^")_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"_COMP_COMP_$$HLDATE^HLFNC(HISTDT,"DT") ;**707 ONLY DATE NOT TIME "RTN","VAFCQRY1",96,0) ; "RTN","VAFCQRY1",97,0) ALTID ;**874 MVI_3035 (elz) alternate ID "RTN","VAFCQRY1",98,0) I $D(SARY(4))!(SEQ="ALL") D "RTN","VAFCQRY1",99,0) . S REF=$NA(APID(5)),@REF="",LVL=0 "RTN","VAFCQRY1",100,0) . I $G(DFN) D "RTN","VAFCQRY1",101,0) .. ;VIC card number, station 742V1 "RTN","VAFCQRY1",102,0) .. N VAVICF,VAVICX,VAVIC,X "RTN","VAFCQRY1",103,0) .. S VAVICF=+$$LKUP^XUAF4("742V1") "RTN","VAFCQRY1",104,0) .. S VAVICX=0 F S VAVICX=$O(^DGCN(391.91,"APAT",DFN,VAVICF,VAVICX)) Q:'VAVICX D "RTN","VAFCQRY1",105,0) ... F X=0,2 S VAVIC(X)=$G(^DGCN(391.91,VAVICX,X)) "RTN","VAFCQRY1",106,0) ... I $P(VAVIC(2),"^",2),$P(VAVIC(2),"^",3)'="H",$L($P(VAVIC(2),"^")),$L($P(VAVIC(0),"^",9)) D "RTN","VAFCQRY1",107,0) .... D ADDLINE($P(VAVIC(2),"^",2)_COMP_COMP_COMP_$P(VAVIC(2),"^")_SUBCOMP_SUBCOMP_"0363"_COMP_$P(VAVIC(0),"^",9)_COMP_"VA FACILITY ID"_SUBCOMP_"742V1"_SUBCOMP_"L",.LVL,REF,REP) "RTN","VAFCQRY1",108,0) ; "RTN","VAFCQRY1",109,0) NAMEPID ;patient name (last^first^middle^suffix^prefix^^"L" for legal) "RTN","VAFCQRY1",110,0) I $D(SARY(5))!(SEQ="ALL") D "RTN","VAFCQRY1",111,0) .;**711 code REMOVED PREFIX due to issues with existing PATIENT Name Standardization functionality "RTN","VAFCQRY1",112,0) .N X S X=$P(VAFCZN,"^") D NAME^VAFCPID2(DFN,.X) S APID(6)=$$HLNAME^XLFNAME(X,"",$E(HL("ECH"),1)) I $P(APID(6),$E(HL("ECH"),1),7)'="L" S $P(APID(6),$E(HL("ECH"),1),7)="L" "RTN","VAFCQRY1",113,0) PREFNAME .; Story 455447 (elz)DG*5.3*937 Preferred Name (^preferred name^^^^^"N" for nickname) "RTN","VAFCQRY1",114,0) .N PREFNAM S PREFNAM=$P($G(^DPT(DFN,.24)),"^",5) "RTN","VAFCQRY1",115,0) .D HL7TXT(.PREFNAM,.HL,HLES) S APID(6)=APID(6)_$S(APID(6)]"":REP,1:"")_$S(PREFNAM]"":PREFNAM,1:"""""")_COMP_COMP_COMP_COMP_COMP_COMP_"N" "RTN","VAFCQRY1",116,0) ALIAS .;patient alias (last^first^middle^suffice^prefix^^"A" for alias - can be multiple) "RTN","VAFCQRY1",117,0) .N ALIAS,ALIEN,LVL6,NXTC,LNGTH S NXTC=0,LVL6=0 "RTN","VAFCQRY1",118,0) .I $D(VAFCA1) S ALIEN=0 F S ALIEN=$O(VAFCA1(ALIEN)) Q:'ALIEN D "RTN","VAFCQRY1",119,0) ..;**974,Story 841921 (mko): Get the Name Components themselves "RTN","VAFCQRY1",120,0) ..; rather than parsing them out of the Name field "RTN","VAFCQRY1",121,0) ..I $G(VAFCA1(ALIEN,"NCIEN"))>0 D "RTN","VAFCQRY1",122,0) ...N NAMEC "RTN","VAFCQRY1",123,0) ...S NAMEC("FILE")=2.01,NAMEC("IENS")=$P(VAFCA1(ALIEN,"NCIEN"),"^",2),NAMEC("FIELD")=.01 "RTN","VAFCQRY1",124,0) ...S ALIAS=$$HLNAME^XLFNAME(.NAMEC,"",$E(HL("ECH"))) "RTN","VAFCQRY1",125,0) ..E S ALIAS=$$HLNAME^XLFNAME(VAFCA1(ALIEN,"NAME"),"",$E(HL("ECH"),1)) "RTN","VAFCQRY1",126,0) ..Q:ALIAS="" "RTN","VAFCQRY1",127,0) ..S $P(ALIAS,$E(HL("ECH"),1),7)="A" "RTN","VAFCQRY1",128,0) ..I LVL6=0 D "RTN","VAFCQRY1",129,0) ...I $L(APID(6)_ALIAS)'>244 S APID(6)=APID(6)_REP_ALIAS Q "RTN","VAFCQRY1",130,0) ...I $L(APID(6)_ALIAS)>244 S LVL6=1 S LNGTH=244-$L(APID(6)),APID(6)=APID(6)_REP_$E(ALIAS,1,LNGTH) S LNGTH=LNGTH+1,ALIAS=$E(ALIAS,LNGTH,$L(ALIAS)),NXTC=1 "RTN","VAFCQRY1",131,0) ..I LVL6>0 D "RTN","VAFCQRY1",132,0) ...I $L($G(APID(6,LVL6))_ALIAS)'>245 S APID(6,LVL6)=$G(APID(6,LVL6))_$S(NXTC=0:REP,1:"")_ALIAS Q "RTN","VAFCQRY1",133,0) ...I $L($G(APID(6,LVL6))_ALIAS)>245 S LNGTH=244-$L(APID(6,LVL6)),APID(6,LVL6)=APID(6,LVL6)_REP_$E(ALIAS,1,LNGTH) S LNGTH=LNGTH+1,ALIAS=$E(ALIAS,LNGTH,$L(ALIAS)) S LVL6=LVL6+1 S APID(6,LVL6)=ALIAS "RTN","VAFCQRY1",134,0) ..I NXTC=1 S NXTC=0 "RTN","VAFCQRY1",135,0) . I APID(6)="" S APID(6)=HL("Q") "RTN","VAFCQRY1",136,0) MOTHER ;mother's maiden name (last^first^middle^suffix^prefix^^"M" for maiden name) "RTN","VAFCQRY1",137,0) I $D(SARY(6))!(SEQ="ALL") D "RTN","VAFCQRY1",138,0) .S APID(7)=HL("Q") "RTN","VAFCQRY1",139,0) .I $D(^DPT(DFN,.24)) S VAFCMMN=$P(^DPT(DFN,.24),"^",3) D "RTN","VAFCQRY1",140,0) ..S APID(7)=$$HLNAME^XLFNAME(VAFCMMN,"",$E(HL("ECH"),1)) I APID(7)="" S APID(7)=HL("Q") "RTN","VAFCQRY1",141,0) ..I $P(APID(7),$E(HL("ECH"),1),7)'="M" S $P(APID(7),$E(HL("ECH"),1),7)="M" "RTN","VAFCQRY1",142,0) .I APID(7)="" S APID(7)=HL("Q") "RTN","VAFCQRY1",143,0) I $D(SARY(7))!(SEQ="ALL") S APID(8)=$$HLDATE^HLFNC($P(VAFCZN,"^",3)) I APID(8)="" S APID(8)=HL("Q") ;date/time of birth "RTN","VAFCQRY1",144,0) I $D(SARY(8))!(SEQ="ALL") S APID(9)=$P(VAFCZN,"^",2) I APID(9)="" S APID(9)=HL("Q") ;sex "RTN","VAFCQRY1",145,0) ;place of birth city and state "RTN","VAFCQRY1",146,0) ;split into 2 routines **707 "RTN","VAFCQRY1",147,0) D CONT^VAFCQRY3(DFN,.APID,.PID,.HL,HLES,.SARY,SEQ,.ERR,REP,COMP,SSN,VAFCMN) "RTN","VAFCQRY1",148,0) D KVA^VADPT "RTN","VAFCQRY1",149,0) Q "RTN","VAFCQRY1",150,0) HL7TXT(HL7STRG,HL,HLES) ; Replace occurrences of embedded HL7 delimiters with "RTN","VAFCQRY1",151,0) ; HL7 escape sequence "RTN","VAFCQRY1",152,0) ; "RTN","VAFCQRY1",153,0) ; Inputs: HL7STRG - Data string to be checked "RTN","VAFCQRY1",154,0) ; HL("ECH") - HL7 delimiter string "RTN","VAFCQRY1",155,0) ; Delimiters MUST be in the following order, "RTN","VAFCQRY1",156,0) ; Escape, Field, Component, Repeat, Subcomponent "RTN","VAFCQRY1",157,0) ; Example: \^~|& "RTN","VAFCQRY1",158,0) ; "RTN","VAFCQRY1",159,0) ; Output: HL7XTRG - Data string with escape sequence added (if needed) "RTN","VAFCQRY1",160,0) ; "RTN","VAFCQRY1",161,0) N OCHR,RCHR,RCHRI,TYPE,I,HLES2 "RTN","VAFCQRY1",162,0) ; "RTN","VAFCQRY1",163,0) I $G(HL("COMP"))="" S HL("COMP")=$E(HL("ECH"),1),HL("REP")=$E(HL("ECH"),2),HL("SUBCOMP")=$E(HL("ECH"),4) "RTN","VAFCQRY1",164,0) ; Set HL7 escape char "RTN","VAFCQRY1",165,0) S HLES2=HLES_HL("FS")_HL("COMP")_HL("REP")_HL("SUBCOMP") "RTN","VAFCQRY1",166,0) ; "RTN","VAFCQRY1",167,0) ; Search for occurrence of each delimiter and replace it with "\\" "RTN","VAFCQRY1",168,0) F TYPE="E","F","C","R","S" D "RTN","VAFCQRY1",169,0) . S RCHRI=$S(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5) "RTN","VAFCQRY1",170,0) . ; "RTN","VAFCQRY1",171,0) . ; OCHR=original char, RCHR=replacement char "RTN","VAFCQRY1",172,0) . S OCHR=$E(HLES2,RCHRI),RCHR=$E("EFSRT",RCHRI) Q:'$F(HL7STRG,OCHR) "RTN","VAFCQRY1",173,0) . F I=1:1 Q:$E(HL7STRG,I)="" I $E(HL7STRG,I)=OCHR S HL7STRG=$E(HL7STRG,1,I-1)_HLES_RCHR_HLES_$E(HL7STRG,I+1,999),I=I+2 "RTN","VAFCQRY1",174,0) Q "RTN","VAFCQRY1",175,0) ; "RTN","VAFCQRY1",176,0) ADDLINE(NXT,LVL,REF,REP) ; Prepend REP to NXT and add it to the @REF "RTN","VAFCQRY1",177,0) ; array, starting at subscript LVL. If appending NXT causes the node "RTN","VAFCQRY1",178,0) ; to exceed 245 chars in length, add as much of NXT as possible to the "RTN","VAFCQRY1",179,0) ; current level, and the remaining at the next level. "RTN","VAFCQRY1",180,0) ; In: "RTN","VAFCQRY1",181,0) ; NXT = string to add to the @REF array "RTN","VAFCQRY1",182,0) ; .LVL = current subscript level (passed by referenced) "RTN","VAFCQRY1",183,0) ; REF = array reference string "RTN","VAFCQRY1",184,0) ; REP = repetition character (e.g., |) "RTN","VAFCQRY1",185,0) ; **837,MVI_879: Created this subroutine to aid in adding TIN and FIN to PID-3. "RTN","VAFCQRY1",186,0) N LNGTH,CURREF "RTN","VAFCQRY1",187,0) S:$G(LVL)<1 LVL=0 "RTN","VAFCQRY1",188,0) S CURREF=$S(LVL=0:REF,1:$NA(@REF@(LVL))) "RTN","VAFCQRY1",189,0) I LVL>0!($G(@CURREF)]"") S NXT=REP_NXT "RTN","VAFCQRY1",190,0) I $L($G(@CURREF))+$L(NXT)'>245 S @CURREF=$G(@CURREF)_NXT "RTN","VAFCQRY1",191,0) E S LNGTH=245-$L(@CURREF),@CURREF=@CURREF_$E(NXT,1,LNGTH),LVL=LVL+1,@REF@(LVL)=$E(NXT,LNGTH+1,$L(NXT)) "RTN","VAFCQRY1",192,0) Q "VER") 8.0^22.2 "BLD",3372,6) ^855 **END** **END**