Released DG*5.3*1071 SEQ #940 Extracted from mail message **KIDS**:DG*5.3*1071^ **INSTALL NAME** DG*5.3*1071 "BLD",3746,0) DG*5.3*1071^REGISTRATION^0^3220518^y "BLD",3746,1,0) ^9.61A^3^3^3220427^^^^ "BLD",3746,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENT - SEXUAL ORIENTATION UPDATES "BLD",3746,1,2,0) Refer to patch DG*5.3*1071 in the FORUM Patch Module for a complete "BLD",3746,1,3,0) description. "BLD",3746,4,0) ^9.64PA^2^1 "BLD",3746,4,2,0) 2 "BLD",3746,4,2,2,0) ^9.641^2^2 "BLD",3746,4,2,2,2,0) PATIENT (File-top level) "BLD",3746,4,2,2,2,1,0) ^9.6411^.0251^1 "BLD",3746,4,2,2,2,1,.0251,0) SEXUAL ORIENTATION DESCRIPTION "BLD",3746,4,2,2,2.025,0) SEXUAL ORIENTATION (sub-file) "BLD",3746,4,2,2,2.025,1,0) ^9.6411^.06^6 "BLD",3746,4,2,2,2.025,1,.01,0) SEXUAL ORIENTATION "BLD",3746,4,2,2,2.025,1,.02,0) STATUS "BLD",3746,4,2,2,2.025,1,.03,0) DATE CREATED "BLD",3746,4,2,2,2.025,1,.04,0) DATE LAST UPDATED "BLD",3746,4,2,2,2.025,1,.05,0) NOTE "BLD",3746,4,2,2,2.025,1,.06,0) TYPE OF UPDATE "BLD",3746,4,2,222) y^n^p^^^^n^^n "BLD",3746,4,2,224) "BLD",3746,4,"APDD",2,2) "BLD",3746,4,"APDD",2,2,.0251) "BLD",3746,4,"APDD",2,2.025) "BLD",3746,4,"APDD",2,2.025,.01) "BLD",3746,4,"APDD",2,2.025,.02) "BLD",3746,4,"APDD",2,2.025,.03) "BLD",3746,4,"APDD",2,2.025,.04) "BLD",3746,4,"APDD",2,2.025,.05) "BLD",3746,4,"APDD",2,2.025,.06) "BLD",3746,4,"B",2,2) "BLD",3746,6) 4 "BLD",3746,6.3) 4 "BLD",3746,"INID") ^n "BLD",3746,"INIT") POST^DG1071P "BLD",3746,"KRN",0) ^9.67PA^1.5^25 "BLD",3746,"KRN",.4,0) .4 "BLD",3746,"KRN",.4,"NM",0) ^9.68A^^ "BLD",3746,"KRN",.401,0) .401 "BLD",3746,"KRN",.402,0) .402 "BLD",3746,"KRN",.403,0) .403 "BLD",3746,"KRN",.5,0) .5 "BLD",3746,"KRN",.84,0) .84 "BLD",3746,"KRN",1.5,0) 1.5 "BLD",3746,"KRN",1.6,0) 1.6 "BLD",3746,"KRN",1.61,0) 1.61 "BLD",3746,"KRN",1.62,0) 1.62 "BLD",3746,"KRN",3.6,0) 3.6 "BLD",3746,"KRN",3.8,0) 3.8 "BLD",3746,"KRN",9.2,0) 9.2 "BLD",3746,"KRN",9.8,0) 9.8 "BLD",3746,"KRN",9.8,"NM",0) ^9.68A^9^9 "BLD",3746,"KRN",9.8,"NM",1,0) VAFCPDAT^^0^B88865297 "BLD",3746,"KRN",9.8,"NM",2,0) VAFCTR^^0^B13948610 "BLD",3746,"KRN",9.8,"NM",3,0) DGRPD^^0^B128108199 "BLD",3746,"KRN",9.8,"NM",4,0) VADPT1^^0^B74338795 "BLD",3746,"KRN",9.8,"NM",5,0) VAFCAPI^^0^B139478624 "BLD",3746,"KRN",9.8,"NM",6,0) VAFCSB^^0^B81393667 "BLD",3746,"KRN",9.8,"NM",7,0) VAFCPTED^^0^B87903386 "BLD",3746,"KRN",9.8,"NM",8,0) DG1071P^^0^B6724117 "BLD",3746,"KRN",9.8,"NM",9,0) VAFCCRNR^^0^B8135519 "BLD",3746,"KRN",9.8,"NM","B","DG1071P",8) "BLD",3746,"KRN",9.8,"NM","B","DGRPD",3) "BLD",3746,"KRN",9.8,"NM","B","VADPT1",4) "BLD",3746,"KRN",9.8,"NM","B","VAFCAPI",5) "BLD",3746,"KRN",9.8,"NM","B","VAFCCRNR",9) "BLD",3746,"KRN",9.8,"NM","B","VAFCPDAT",1) "BLD",3746,"KRN",9.8,"NM","B","VAFCPTED",7) "BLD",3746,"KRN",9.8,"NM","B","VAFCSB",6) "BLD",3746,"KRN",9.8,"NM","B","VAFCTR",2) "BLD",3746,"KRN",19,0) 19 "BLD",3746,"KRN",19.1,0) 19.1 "BLD",3746,"KRN",101,0) 101 "BLD",3746,"KRN",409.61,0) 409.61 "BLD",3746,"KRN",771,0) 771 "BLD",3746,"KRN",779.2,0) 779.2 "BLD",3746,"KRN",870,0) 870 "BLD",3746,"KRN",8989.51,0) 8989.51 "BLD",3746,"KRN",8989.52,0) 8989.52 "BLD",3746,"KRN",8993,0) 8993 "BLD",3746,"KRN",8994,0) 8994 "BLD",3746,"KRN","B",.4,.4) "BLD",3746,"KRN","B",.401,.401) "BLD",3746,"KRN","B",.402,.402) "BLD",3746,"KRN","B",.403,.403) "BLD",3746,"KRN","B",.5,.5) "BLD",3746,"KRN","B",.84,.84) "BLD",3746,"KRN","B",1.5,1.5) "BLD",3746,"KRN","B",1.6,1.6) "BLD",3746,"KRN","B",1.61,1.61) "BLD",3746,"KRN","B",1.62,1.62) "BLD",3746,"KRN","B",3.6,3.6) "BLD",3746,"KRN","B",3.8,3.8) "BLD",3746,"KRN","B",9.2,9.2) "BLD",3746,"KRN","B",9.8,9.8) "BLD",3746,"KRN","B",19,19) "BLD",3746,"KRN","B",19.1,19.1) "BLD",3746,"KRN","B",101,101) "BLD",3746,"KRN","B",409.61,409.61) "BLD",3746,"KRN","B",771,771) "BLD",3746,"KRN","B",779.2,779.2) "BLD",3746,"KRN","B",870,870) "BLD",3746,"KRN","B",8989.51,8989.51) "BLD",3746,"KRN","B",8989.52,8989.52) "BLD",3746,"KRN","B",8993,8993) "BLD",3746,"KRN","B",8994,8994) "BLD",3746,"QDEF") ^^^^NO^^^^NO^^YES "BLD",3746,"QUES",0) ^9.62^^ "BLD",3746,"REQB",0) ^9.611^5^3 "BLD",3746,"REQB",3,0) DG*5.3*1050^2 "BLD",3746,"REQB",4,0) DG*5.3*1059^2 "BLD",3746,"REQB",5,0) DG*5.3*1067^2 "BLD",3746,"REQB","B","DG*5.3*1050",3) "BLD",3746,"REQB","B","DG*5.3*1059",4) "BLD",3746,"REQB","B","DG*5.3*1067",5) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^n^p^^^^n^^n "FIA",2,0,10) "FIA",2,0,11) "FIA",2,0,"RLRO") "FIA",2,0,"VR") 5.3^DG "FIA",2,2) 1 "FIA",2,2,.025) "FIA",2,2,.0251) "FIA",2,2.025) 1 "FIA",2,2.025,.01) "FIA",2,2.025,.02) "FIA",2,2.025,.03) "FIA",2,2.025,.04) "FIA",2,2.025,.05) "FIA",2,2.025,.06) "INIT") POST^DG1071P "IX",2,2,"AHIST",0) 2^AHIST^Sexual Orientation Description^MU^^F^IR^I^2^^^^^S "IX",2,2,"AHIST",.1,0) ^^3^3^3220427^ "IX",2,2,"AHIST",.1,1,0) The purpose of this index is to give MPI the ability to rollback Sexual "IX",2,2,"AHIST",.1,2,0) Orientation Description changes to a previous value by looking at the "IX",2,2,"AHIST",.1,3,0) history of the changes that occurred. "IX",2,2,"AHIST",1) D SETSOD^VAFCAPI "IX",2,2,"AHIST",2) D KILLSOD^VAFCAPI "IX",2,2,"AHIST",2.4) "IX",2,2,"AHIST",11.1,0) ^.114IA^1^1 "IX",2,2,"AHIST",11.1,1,0) 1^F^2^.0251^^^F "IX",2,2,"AVAFC0251",0) 2^AVAFC0251^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2^^^^^A "IX",2,2,"AVAFC0251",.1,0) ^^5^5^3210628^ "IX",2,2,"AVAFC0251",.1,1,0) This cross-reference activates the DG FIELD MONITOR event point. "IX",2,2,"AVAFC0251",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2,"AVAFC0251",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2,"AVAFC0251",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2,"AVAFC0251",.1,5,0) the information available at the time of the event. "IX",2,2,"AVAFC0251",1) D FC^DGFCPROT(.DA,2,.0251,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"AVAFC0251",2) D FC^DGFCPROT(.DA,2,.0251,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2,"AVAFC0251",11.1,0) ^.114IA^1^1 "IX",2,2,"AVAFC0251",11.1,1,0) 1^F^2^.0251^^^F "IX",2,2,"AVAFC0251",11.1,1,3) "IX",2,2,"G202501",0) 2^G202501^Index for Date Created and Sexual Orientation.^R^^R^IR^W^2.025^^^^^LS "IX",2,2,"G202501",.1,0) ^^3^3^3220209^ "IX",2,2,"G202501",.1,1,0) The purpose of this index is to allow reporting on the entire PATIENT "IX",2,2,"G202501",.1,2,0) (#2) file, if desired by the date information as initially entered "IX",2,2,"G202501",.1,3,0) related to the Sexual Orientation. "IX",2,2,"G202501",1) S ^DPT("G202501",X(1),X(2),DA(1),DA)="" "IX",2,2,"G202501",2) K ^DPT("G202501",X(1),X(2),DA(1),DA) "IX",2,2,"G202501",2.5) K ^DPT("G202501") "IX",2,2,"G202501",11.1,0) ^.114IA^2^2 "IX",2,2,"G202501",11.1,1,0) 1^F^2.025^.03^^1^F "IX",2,2,"G202501",11.1,2,0) 2^F^2.025^.01^^2^F "IX",2,2,"G202502",0) 2^G202502^Index on the Date Last Updated and Sexual Orientation.^R^^R^IR^W^2.025^^^^^LS "IX",2,2,"G202502",.1,0) ^^3^3^3220209^ "IX",2,2,"G202502",.1,1,0) The purpose of this index is to provide a Date Last Updated "IX",2,2,"G202502",.1,2,0) cross-reference for the entire PATIENT (#2) file for the purposes of "IX",2,2,"G202502",.1,3,0) reporting on updates to the Sexual Orientation information. "IX",2,2,"G202502",1) S ^DPT("G202502",X(1),X(2),DA(1),DA)="" "IX",2,2,"G202502",2) K ^DPT("G202502",X(1),X(2),DA(1),DA) "IX",2,2,"G202502",2.5) K ^DPT("G202502") "IX",2,2,"G202502",11.1,0) ^.114IA^2^2 "IX",2,2,"G202502",11.1,1,0) 1^F^2.025^.04^^1^F "IX",2,2,"G202502",11.1,2,0) 2^F^2.025^.01^^2^F "IX",2,2,"G202503",0) 2^G202503^Index by Sexual Orientation and Date Created.^R^^R^IR^W^2.025^^^^^LS "IX",2,2,"G202503",.1,0) ^^2^2^3220209^ "IX",2,2,"G202503",.1,1,0) The purpose of this index is to cross-reference all the Sexual "IX",2,2,"G202503",.1,2,0) Orientations by the date they were created for a patient. "IX",2,2,"G202503",1) S ^DPT("G202503",X(1),X(2),DA(1),DA)="" "IX",2,2,"G202503",2) K ^DPT("G202503",X(1),X(2),DA(1),DA) "IX",2,2,"G202503",2.5) K ^DPT("G202503") "IX",2,2,"G202503",11.1,0) ^.114IA^2^2 "IX",2,2,"G202503",11.1,1,0) 1^F^2.025^.01^^1^F "IX",2,2,"G202503",11.1,2,0) 2^F^2.025^.03^^2^F "IX",2,2,"G202504",0) 2^G202504^Index by Sexual Orientation and Date Last Updated.^R^^R^IR^W^2.025^^^^^LS "IX",2,2,"G202504",.1,0) ^^2^2^3220209^ "IX",2,2,"G202504",.1,1,0) The purpose of this index is to provide a cross-reference by all of the "IX",2,2,"G202504",.1,2,0) Sexual Orientations for patient by the date they were last updated. "IX",2,2,"G202504",1) S ^DPT("G202504",X(1),X(2),DA(1),DA)="" "IX",2,2,"G202504",2) K ^DPT("G202504",X(1),X(2),DA(1),DA) "IX",2,2,"G202504",2.5) K ^DPT("G202504") "IX",2,2,"G202504",11.1,0) ^.114IA^2^2 "IX",2,2,"G202504",11.1,1,0) 1^F^2.025^.01^^1^F "IX",2,2,"G202504",11.1,1,3) "IX",2,2,"G202504",11.1,2,0) 2^F^2.025^.04^^2^F "IX",2,2,"G202504",11.1,2,3) "IX",2,2.025,"AHIST",0) 2.025^AHIST^Sexual Orientation History^MU^^R^IR^I^2.025^^^^^S "IX",2,2.025,"AHIST",.1,0) ^^3^3^3220427^^ "IX",2,2.025,"AHIST",.1,1,0) The purpose of this index is to give MPI the ability to rollback Sexual "IX",2,2.025,"AHIST",.1,2,0) Orientation changes to previous values by looking at the history of "IX",2,2.025,"AHIST",.1,3,0) changes that occurred. "IX",2,2.025,"AHIST",1) D SETSO^VAFCAPI "IX",2,2.025,"AHIST",2) D KILLSO^VAFCAPI "IX",2,2.025,"AHIST",2.4) "IX",2,2.025,"AHIST",2.5) K ^DPT(DA(1),.025,"AHIST") "IX",2,2.025,"AHIST",11.1,0) ^.114IA^6^6 "IX",2,2.025,"AHIST",11.1,1,0) 1^F^2.025^.01^^^F "IX",2,2.025,"AHIST",11.1,2,0) 2^F^2.025^.02^^^F "IX",2,2.025,"AHIST",11.1,3,0) 3^F^2.025^.03^^^F "IX",2,2.025,"AHIST",11.1,4,0) 4^F^2.025^.04^^^F "IX",2,2.025,"AHIST",11.1,5,0) 5^F^2.025^.05^^^F "IX",2,2.025,"AHIST",11.1,6,0) 6^F^2.025^.06^^^F "IX",2,2.025,"AVAFC202501",0) 2.025^AVAFC202501^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2.025^^^^^A "IX",2,2.025,"AVAFC202501",.1,0) ^^5^5^3220512^^^ "IX",2,2.025,"AVAFC202501",.1,1,0) This cross-reference activates the DG FIELD MONITOR event point. "IX",2,2.025,"AVAFC202501",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2.025,"AVAFC202501",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2.025,"AVAFC202501",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2.025,"AVAFC202501",.1,5,0) the information available at the time of the event. "IX",2,2.025,"AVAFC202501",1) D FC^DGFCPROT(.DA,2.025,.01,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202501",2) D FC^DGFCPROT(.DA,2.025,.01,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202501",11.1,0) ^.114IA^1^1 "IX",2,2.025,"AVAFC202501",11.1,1,0) 1^F^2.025^.01^^^F "IX",2,2.025,"AVAFC202502",0) 2.025^AVAFC202502^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2.025^^^^^A "IX",2,2.025,"AVAFC202502",.1,0) ^^5^5^3220119^ "IX",2,2.025,"AVAFC202502",.1,1,0) This cross-reference activates the DG FIELD MONITOR event point. "IX",2,2.025,"AVAFC202502",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2.025,"AVAFC202502",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2.025,"AVAFC202502",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2.025,"AVAFC202502",.1,5,0) the information available at the time of the event. "IX",2,2.025,"AVAFC202502",1) D FC^DGFCPROT(.DA,2.025,.02,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202502",2) D FC^DGFCPROT(.DA,2.025,.02,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202502",11.1,0) ^.114IA^1^1 "IX",2,2.025,"AVAFC202502",11.1,1,0) 1^F^2.025^.02^^^F "IX",2,2.025,"AVAFC202502",11.1,1,3) "IX",2,2.025,"AVAFC202503",0) 2.025^AVAFC202503^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2.025^^^^^A "IX",2,2.025,"AVAFC202503",.1,0) ^^5^5^3220119^ "IX",2,2.025,"AVAFC202503",.1,1,0) This cross-reference activates the DG FIELD MONITOR event point. "IX",2,2.025,"AVAFC202503",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2.025,"AVAFC202503",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2.025,"AVAFC202503",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2.025,"AVAFC202503",.1,5,0) the information available at the time of the event. "IX",2,2.025,"AVAFC202503",1) D FC^DGFCPROT(.DA,2.025,.03,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202503",2) D FC^DGFCPROT(.DA,2.025,.03,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202503",11.1,0) ^.114IA^1^1 "IX",2,2.025,"AVAFC202503",11.1,1,0) 1^F^2.025^.03^^^F "IX",2,2.025,"AVAFC202503",11.1,1,3) "IX",2,2.025,"AVAFC202504",0) 2.025^AVAFC202504^This x-ref calls the DG FIELD MONITOR event point.^MU^^F^I^I^2.025^^^^^A "IX",2,2.025,"AVAFC202504",.1,0) ^^5^5^3220119^ "IX",2,2.025,"AVAFC202504",.1,1,0) This cross-reference activates the DG FIELD MONITOR event point. "IX",2,2.025,"AVAFC202504",.1,2,0) Applications that wish to monitor edit activity related to this field may "IX",2,2.025,"AVAFC202504",.1,3,0) subscribe to that event point and take action as indicated by the changes "IX",2,2.025,"AVAFC202504",.1,4,0) that occur. Refer to the DG FIELD MONITOR protocol for a description of "IX",2,2.025,"AVAFC202504",.1,5,0) the information available at the time of the event. "IX",2,2.025,"AVAFC202504",1) D FC^DGFCPROT(.DA,2.025,.04,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202504",2) D FC^DGFCPROT(.DA,2.025,.04,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q "IX",2,2.025,"AVAFC202504",11.1,0) ^.114IA^1^1 "IX",2,2.025,"AVAFC202504",11.1,1,0) 1^F^2.025^.04^^^F "MBREQ") 0 "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) 1071^3220518 "PKG",5,22,1,"PAH",1,1,0) ^^3^3^3220518 "PKG",5,22,1,"PAH",1,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENT - SEXUAL ORIENTATION UPDATES "PKG",5,22,1,"PAH",1,1,2,0) Refer to patch DG*5.3*1071 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") 9 "RTN","DG1071P") 0^8^B6724117^n/a "RTN","DG1071P",1,0) DG1071P ;BIR/JFW - DG*5.3*1071 Post-Init ;2/22/22 16:02 "RTN","DG1071P",2,0) ;;5.3;Registration;**1071**;Aug 13, 1993;Build 4 "RTN","DG1071P",3,0) ; "RTN","DG1071P",4,0) ;BMES^XPDUTL and MES^XPDUTL - DBIA #10141 Supported "RTN","DG1071P",5,0) ; "RTN","DG1071P",6,0) ;STORY VAMPI-13802 (jfw) - Enable Auditing on PHONE NUMBER [CELLULAR] "RTN","DG1071P",7,0) ;STORY VAMPI-13671 (dri) - File '200CRNR' as this site's Cerner Station Number "RTN","DG1071P",8,0) ; "RTN","DG1071P",9,0) POST ; "RTN","DG1071P",10,0) D BMES^XPDUTL("Post-Install: Starting") "RTN","DG1071P",11,0) D ENAUDIT ;Enable auditing on Cell Phone (#.134) in the PATIENT File (#2) "RTN","DG1071P",12,0) I $D(^MPIF(984.8)) D DEFCRNR ;File '200CRNR' as this site's Cerner Station Number, only file at sites installing mpif* patches (not legacy, forum, claims, etc.) "RTN","DG1071P",13,0) D BMES^XPDUTL("Post-Install: Finished") "RTN","DG1071P",14,0) Q "RTN","DG1071P",15,0) ; "RTN","DG1071P",16,0) ENAUDIT ;Enable auditing on PATIENT (#2) field PHONE NUMBER [CELLULAR] (#.134) "RTN","DG1071P",17,0) D BMES^XPDUTL(" >> Enabled AUDIT(ing) on the PHONE NUMBER [CELLULAR] field") "RTN","DG1071P",18,0) D MES^XPDUTL(" in the PATIENT (#2) file!") "RTN","DG1071P",19,0) D TURNON^DIAUTL(2,.134) ;DBIA #4397 Supported "RTN","DG1071P",20,0) Q "RTN","DG1071P",21,0) ; "RTN","DG1071P",22,0) DEFCRNR ;File '200CRNR' as the Cerner Station Number for this site "RTN","DG1071P",23,0) ; "RTN","DG1071P",24,0) ;all sites will default to '200CRNR' "RTN","DG1071P",25,0) ;some test environments could be updated to something else "RTN","DG1071P",26,0) ; "RTN","DG1071P",27,0) N DGFAC,DGIEN,DGMSG,DIERR,FDA,IEN "RTN","DG1071P",28,0) S DGFAC="200CRNR" ;default Cerner Station Number "RTN","DG1071P",29,0) D BMES^XPDUTL(" >> Filing '"_DGFAC_"' as the Cerner Station Number for this site.") "RTN","DG1071P",30,0) S DGIEN=$O(^MPIF(984.8,"B","FOUR",0)) I DGIEN D BMES^XPDUTL(" >> '"_$P($G(^MPIF(984.8,DGIEN,0)),"^",5)_"' already defined for this site.") Q "RTN","DG1071P",31,0) S FDA(984.8,"?+1,",.01)="FOUR" "RTN","DG1071P",32,0) S FDA(984.8,"?+1,",4)=DGFAC ;STATUS (#4) field in the MPI ICN BUILD MANAGEMENT (#984.8) file "RTN","DG1071P",33,0) S IEN(1)=4 "RTN","DG1071P",34,0) D UPDATE^DIE("E","FDA","IEN","DGMSG") "RTN","DG1071P",35,0) I $D(DGMSG) D BMES^XPDUTL(" >> ERROR!! The Cerner Station Number, '"_DGFAC_"' was NOT filed."),MES^XPDUTL(" [#"_$G(DGMSG("DIERR",1))_": "_$G(DGMSG("DIERR",1,"TEXT",1))_"]") Q "RTN","DG1071P",36,0) D MES^XPDUTL(" >> '"_DGFAC_"' successfully filed.") "RTN","DG1071P",37,0) Q "RTN","DG1071P",38,0) ; "RTN","DGRPD") 0^3^B128108199^B124542170 "RTN","DGRPD",1,0) DGRPD ;ALB/MRL,MLR,JAN,LBD,EG,BRM,JRC,BAJ,JAM,HM,BDB,ARF,RN -PATIENT INQUIRY (NEW) ;July 09, 2014 12:16pm "RTN","DGRPD",2,0) ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,688,887,907,925,936,940,941,987,1006,1056,1061,1059,1071**;Aug 13, 1993;Build 4 "RTN","DGRPD",3,0) ; *286* Newing variables X,Y in OKLINE subroutine "RTN","DGRPD",4,0) ; *358* If a patient is on a domiciliary ward, don't display MEANS "RTN","DGRPD",5,0) ; TEST required/Medication Copayment Exemption messages "RTN","DGRPD",6,0) ; *436* If an inpatient is not on a domiciliary ward, don't display "RTN","DGRPD",7,0) ; Medication Copayment Exemption message "RTN","DGRPD",8,0) ; *545* Add death information near the remarks field "RTN","DGRPD",9,0) ; *677* Added Emergency Response "RTN","DGRPD",10,0) ; *688* Modified to display Country and Foreign Address "RTN","DGRPD",11,0) ; *936* Modified to display Health Benefit Plans "RTN","DGRPD",12,0) ; *940* #879316,#879318 - Display Permanent & Total Disabled Status "RTN","DGRPD",13,0) ; *941* #887088 - Redesign of Inquiry Screen layout for displaying the addresses "RTN","DGRPD",14,0) ; "RTN","DGRPD",15,0) ; Integration Agreements: "RTN","DGRPD",16,0) ; 6138 - DGHBPUTL API "RTN","DGRPD",17,0) ; "RTN","DGRPD",18,0) SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL "RTN","DGRPD",19,0) EN ;call to display patient inquiry - input DFN "RTN","DGRPD",20,0) ;MPI/PD CHANGE "RTN","DGRPD",21,0) S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI")) "RTN","DGRPD",22,0) K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1 "RTN","DGRPD",23,0) ;JAM begin changes Patch DG*5.3*941 add .115 and new address fields layout "RTN","DGRPD",24,0) F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3,.115 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPD",25,0) ;jam DG*5.3*925 RM#788099 change labels to "Permanent Mailing Address" and "Temporary Mailing Address" "RTN","DGRPD",26,0) ; "RTN","DGRPD",27,0) W " Residential Address: " "RTN","DGRPD",28,0) W ?40,"Mailing Address: " ;DG*5.3*1056 remove Permanent from the address label "RTN","DGRPD",29,0) S DGAD=.115,(DGA1,DGA2)=1 D AL^DGRPU(35) S DGAD=.11,DGA1=1,DGA2=2 D AL^DGRPU(35) "RTN","DGRPD",30,0) W !?5 "RTN","DGRPD",31,0) N Z,Z1 "RTN","DGRPD",32,0) S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO PERMANENT MAILING ADDRESS") "RTN","DGRPD",33,0) ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens) "RTN","DGRPD",34,0) S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I) "RTN","DGRPD",35,0) N DGCC "RTN","DGRPD",36,0) S DGCC=$$COUNTY^DGRPCADD(.DGRP,.115) ; print County if applicable "RTN","DGRPD",37,0) W !?5,"County: "_DGCC "RTN","DGRPD",38,0) S DGCC=$$COUNTY^DGRPCADD(.DGRP,.11) ; print County if applicable "RTN","DGRPD",39,0) W ?44,"County: "_DGCC "RTN","DGRPD",40,0) W !?6,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU) "RTN","DGRPD",41,0) W ?42,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16)) "RTN","DGRPD",42,0) W !?5,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU) "RTN","DGRPD",43,0) W ?46,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU) "RTN","DGRPD",44,0) W !?44,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU) "RTN","DGRPD",45,0) W !! "RTN","DGRPD",46,0) K DGA,DGA1,DGA2 "RTN","DGRPD",47,0) I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,(DGA1,DGA2)=1 D AL^DGRPU(30) "RTN","DGRPD",48,0) N CONACT "RTN","DGRPD",49,0) ; set Confidential Active Flag "RTN","DGRPD",50,0) S CONACT=$P(DGRP(.141),"^",9) "RTN","DGRPD",51,0) I CONACT="Y" D "RTN","DGRPD",52,0) .; check the begin/end dates, set active flag to NO and do not display if outside the date range "RTN","DGRPD",53,0) .N DGCABEG,DGCAEND,DGI "RTN","DGRPD",54,0) .S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8) "RTN","DGRPD",55,0) .I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND40) !?5 W:'(I#2) ?44 W DGA(I) "RTN","DGRPD",63,0) W ! "RTN","DGRPD",64,0) I $D(DGA(1)) D "RTN","DGRPD",65,0) .S DGCC=$$COUNTY^DGRPCADD(.DGRP,.121) ; print County if applicable "RTN","DGRPD",66,0) .W ?5,"County: "_DGCC "RTN","DGRPD",67,0) I $D(DGA(2)) D "RTN","DGRPD",68,0) .S DGCC=$$COUNTY^DGRPCADD(.DGRP,.141) ; print County if applicable "RTN","DGRPD",69,0) .W ?44,"County: "_DGCC "RTN","DGRPD",70,0) ;W !?2,"CASS Cert: "_$S($P(DGRP(.121),U,15)="Y":"Certified",$P(DGRP(.121),U,15)="F":"Failed",1:"NC") "RTN","DGRPD",71,0) ;W ?41,"CASS Cert: "_$S($P(DGRP(.141),U,17)="Y":"Certified",$P(DGRP(.141),U,17)="F":"Failed",1:"NC") "RTN","DGRPD",72,0) W !?6,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) "RTN","DGRPD",73,0) W ?45,"Phone: ",$S($P(DGRP(.141),U,9)'="Y":"NOT APPLICABLE",CONACT'="Y":"NOT APPLICABLE",$P(DGRP(.13),U,15)]"":$P(DGRP(.13),U,15),1:DGRPU) "RTN","DGRPD",74,0) S X="NOT APPLICABLE" "RTN","DGRPD",75,0) I $P(DGRP(.121),U,9)="Y" D "RTN","DGRPD",76,0) .S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") "RTN","DGRPD",77,0) .S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") "RTN","DGRPD",78,0) .S X=X_$S(Y]"":Y,1:DGRPU) "RTN","DGRPD",79,0) N DGACT,DGTYP,DGCAN,DGBEG,DGEND,DGZ,DGXX,DGX,DGTYPNAM,DGCAT "RTN","DGRPD",80,0) W !?2,"From/To: ",X "RTN","DGRPD",81,0) S DGX="NOT APPLICABLE" "RTN","DGRPD",82,0) I CONACT="Y" D "RTN","DGRPD",83,0) .S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D "RTN","DGRPD",84,0) ..I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y "RTN","DGRPD",85,0) ..I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED") "RTN","DGRPD",86,0) W ?43,"From/To: "_DGX "RTN","DGRPD",87,0) W !?41,"Confidential Address Categories: " I $D(^DPT(DFN,.14)) D "RTN","DGRPD",88,0) .; If not active, do not display categories "RTN","DGRPD",89,0) .I CONACT'="Y" Q "RTN","DGRPD",90,0) .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR") "RTN","DGRPD",91,0) .S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D "RTN","DGRPD",92,0) ..Q:'$D(^DPT(DFN,.14,DGCAN,0)) "RTN","DGRPD",93,0) ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2) "RTN","DGRPD",94,0) ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered") "RTN","DGRPD",95,0) ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D "RTN","DGRPD",96,0) ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX "RTN","DGRPD",97,0) S DGXX="" F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D "RTN","DGRPD",98,0) .W !?42,DGXX "RTN","DGRPD",99,0) ; "RTN","DGRPD",100,0) I '$$OKLINE^DGRPD1(16) G Q "RTN","DGRPD",101,0) N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^")) "RTN","DGRPD",102,0) W:DGEMER]"" !?32,"Emergency Response: ",DGEMER "RTN","DGRPD",103,0) I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED") "RTN","DGRPD",104,0) I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46 ;,"Birth Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") ; DG*5.3*907 "RTN","DGRPD",105,0) ;**159 REMOVE CONDITIONAL DISPLAY OF BIRTH SEX AND GROUP WITH OTHER SOGI FIELDS "RTN","DGRPD",106,0) I 'DGABBRV W ! D "RTN","DGRPD",107,0) .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF "RTN","DGRPD",108,0) .K ^UTILITY($J,"W") "RTN","DGRPD",109,0) .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D "RTN","DGRPD",110,0) ..S VAL=+$G(^DPT(DFN,.02,PTR,0)) "RTN","DGRPD",111,0) ..Q:$$INACTIVE^DGUTL4(VAL,1) "RTN","DGRPD",112,0) ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", " "RTN","DGRPD",113,0) ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP "RTN","DGRPD",114,0) .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED" "RTN","DGRPD",115,0) .K ^UTILITY($J,"W") "RTN","DGRPD",116,0) .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D "RTN","DGRPD",117,0) ..S VAL=+$G(^DPT(DFN,.06,PTR,0)) "RTN","DGRPD",118,0) ..Q:$$INACTIVE^DGUTL4(VAL,2) "RTN","DGRPD",119,0) ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", " "RTN","DGRPD",120,0) ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP "RTN","DGRPD",121,0) .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED" "RTN","DGRPD",122,0) .K ^UTILITY($J,"W") "RTN","DGRPD",123,0) .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0) "RTN","DGRPD",124,0) .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0)) "RTN","DGRPD",125,0) I '$$OKLINE^DGRPD1(16) G Q "RTN","DGRPD",126,0) ;**1059 ADDING SOGI fields including BIRTH SEX "RTN","DGRPD",127,0) D SOGI "RTN","DGRPD",128,0) D LANGUAGE "RTN","DGRPD",129,0) I '$$OKLINE^DGRPD1(10) G Q "RTN","DGRPD",130,0) ;display cv status #4156 "RTN","DGRPD",131,0) N DGCV S DGCV=$$CVEDT^DGCV(+DFN) "RTN","DGRPD",132,0) W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ") "RTN","DGRPD",133,0) ;DG*5.3*1061 Display COMPACT ACT status only if TRUE "RTN","DGRPD",134,0) N DGCOMPACT S DGCOMPACT=$$CAI^DGENELA(+DFN) "RTN","DGRPD",135,0) I DGCOMPACT=1 W !,?1,"COMPACT Act Status: ELIGIBLE" "RTN","DGRPD",136,0) ; "RTN","DGRPD",137,0) ;display primary eligibility "RTN","DGRPD",138,0) S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU) "RTN","DGRPD",139,0) W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X "RTN","DGRPD",140,0) I '$$OKLINE^DGRPD1(16) G Q "RTN","DGRPD",141,0) ;employability status "RTN","DGRPD",142,0) W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO") "RTN","DGRPD",143,0) I '$$OKLINE^DGRPD1(19) G Q "RTN","DGRPD",144,0) ; KUM DG*5.3*940 RM #879316,#879318 - Display Permanent & Total Disabled status "RTN","DGRPD",145,0) W !?6,"Permanent & Total Disabled: ",$S($P(DGRP(.3),U,4)="Y":"YES",1:"NO") "RTN","DGRPD",146,0) I '$$OKLINE^DGRPD1(19) G Q "RTN","DGRPD",147,0) ;display the catastrophic disability review date if there is one "RTN","DGRPD",148,0) D CATDIS^DGRPD1 "RTN","DGRPD",149,0) I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D "RTN","DGRPD",150,0) . N DGPDT,DGPTM "RTN","DGRPD",151,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",152,0) . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1) "RTN","DGRPD",153,0) . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE") "RTN","DGRPD",154,0) . S DGPTM=$$PCTEAM^DGSDUTL(DFN) "RTN","DGRPD",155,0) . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2) "RTN","DGRPD",156,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",157,0) ; Check if patient is an inpatient and on a DOM ward "RTN","DGRPD",158,0) ; If inpatient is on a DOM ward, don't display MT or CP messages "RTN","DGRPD",159,0) ; If inpatient is NOT on a DOM ward, don't display CP message "RTN","DGRPD",160,0) N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR "RTN","DGRPD",161,0) G Q:'$$OKLINE^DGRPD1(16) "RTN","DGRPD",162,0) D DOM^DGMTR "RTN","DGRPD",163,0) I '$G(DGDOM) D "RTN","DGRPD",164,0) .D DIS^DGMTU(DFN) "RTN","DGRPD",165,0) .D IN5^VADPT "RTN","DGRPD",166,0) .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1) "RTN","DGRPD",167,0) ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W ! "RTN","DGRPD",168,0) D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518) "RTN","DGRPD",169,0) S VAIP("L")="" "RTN","DGRPD",170,0) I $$OKLINE^DGRPD1(14) D INP "RTN","DGRPD",171,0) I '$G(DGRPOUT),($$OKLINE^DGRPD1(10)) D SA ;*KNR* "RTN","DGRPD",172,0) ;MPI/PD CHANGE "RTN","DGRPD",173,0) Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q "RTN","DGRPD",174,0) ; "RTN","DGRPD",175,0) INP S VAIP("D")="L" D INP^DGPMV10 "RTN","DGRPD",176,0) S DGPMT=0 "RTN","DGRPD",177,0) D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q "RTN","DGRPD",178,0) SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE^DGRPD1(17) SAA Q:$G(DGRPOUT) "RTN","DGRPD",179,0) Q "RTN","DGRPD",180,0) SAA ;Scheduled Admit Data "RTN","DGRPD",181,0) W !!?14,"Scheduled Admit" "RTN","DGRPD",182,0) W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U) "RTN","DGRPD",183,0) W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U) "RTN","DGRPD",184,0) W " on "_$$FMTE^XLFDT(L,"5DZ") "RTN","DGRPD",185,0) Q ;SAA "RTN","DGRPD",186,0) ; "RTN","DGRPD",187,0) CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"") "RTN","DGRPD",188,0) ; "RTN","DGRPD",189,0) FA ; "RTN","DGRPD",190,0) N DGARRAY,SDCNT "RTN","DGRPD",191,0) S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P" "RTN","DGRPD",192,0) S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: " "RTN","DGRPD",193,0) ;if there is lower subscripts hanging from the 101 node, "RTN","DGRPD",194,0) ;then it is a valid appointment, otherwise it is "RTN","DGRPD",195,0) ;an error eg 01/20/2005 "RTN","DGRPD",196,0) ;G:'$$OKLINE^DGRPD1(13) RMK ;*///* "RTN","DGRPD",197,0) I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK "RTN","DGRPD",198,0) I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK "RTN","DGRPD",199,0) ; "RTN","DGRPD",200,0) W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "=" "RTN","DGRPD",201,0) F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5 "RTN","DGRPD",202,0) .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";") "RTN","DGRPD",203,0) .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D "RTN","DGRPD",204,0) ..D COV "RTN","DGRPD",205,0) ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z") "RTN","DGRPD",206,0) ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2) "RTN","DGRPD",207,0) ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV "RTN","DGRPD",208,0) ..Q "RTN","DGRPD",209,0) I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments." "RTN","DGRPD",210,0) RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(15)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;*///* "RTN","DGRPD",211,0) D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO") "RTN","DGRPD",212,0) W !! "RTN","DGRPD",213,0) W "Date of Death Information" "RTN","DGRPD",214,0) W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E")) "RTN","DGRPD",215,0) W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E")) "RTN","DGRPD",216,0) W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E")) "RTN","DGRPD",217,0) W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),! "RTN","DGRPD",218,0) I $$OKLINE^DGRPD1(14) D EC^DGRPD1 "RTN","DGRPD",219,0) ; KUM DG*5.3*936 Call tag to display Health Benefit Plans assigned to Veteran "RTN","DGRPD",220,0) D HBP "RTN","DGRPD",221,0) K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky "RTN","DGRPD",222,0) Q "RTN","DGRPD",223,0) ; KUM DG*5.3*936 Display Health Benefit Plans assigned to Veteran "RTN","DGRPD",224,0) HBP ;W !!,"Veteran Medical Benefit Plan Currently Assigned to Veteran:" ;DG*5.3*987 HM "RTN","DGRPD",225,0) W !!,"VHA Profiles Currently Assigned to Veteran:" ;DG*5.3*1006 BDB;DG*5.3*987 HM "RTN","DGRPD",226,0) N DGHBP,HBP,DGCOUNT,DGHBIEN,DGPNAME,X,DGCNT,DGLN,DGLINE "RTN","DGRPD",227,0) S DGCOUNT=0 "RTN","DGRPD",228,0) D GETHBP^DGHBPUTL(DFN) "RTN","DGRPD",229,0) S DGHBP="" F S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP="" D "RTN","DGRPD",230,0) .; DG*5.3*987; jam; Place "zz" before the plan name for inactive plans "RTN","DGRPD",231,0) .S DGHBIEN=+HBP("CUR",DGHBP) "RTN","DGRPD",232,0) .I $P($G(^DGHBP(25.11,DGHBIEN,0)),"^",4)="Y" S DGPNAME="zz "_DGHBP "RTN","DGRPD",233,0) .E S DGPNAME=DGHBP "RTN","DGRPD",234,0) .; DG*5.3*987; arf; Add word wrapping for plan names "RTN","DGRPD",235,0) .S X=DGPNAME "RTN","DGRPD",236,0) .K ^UTILITY($J,"W") S DIWL=0,DIWR=70,DIWF="" D ^DIWP "RTN","DGRPD",237,0) .S DGCNT=^UTILITY($J,"W",0) "RTN","DGRPD",238,0) .F DGLN=1:1:DGCNT S DGLINE=^UTILITY($J,"W",0,DGLN,0) W !,?3,DGLINE "RTN","DGRPD",239,0) .K ^UTILITY($J,"W") "RTN","DGRPD",240,0) .S DGCOUNT=DGCOUNT+1 "RTN","DGRPD",241,0) I DGCOUNT=0 W !,?3,"None" "RTN","DGRPD",242,0) Q "RTN","DGRPD",243,0) ; "RTN","DGRPD",244,0) COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"") "RTN","DGRPD",245,0) S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q "RTN","DGRPD",246,0) Q "RTN","DGRPD",247,0) ; "RTN","DGRPD",248,0) OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME "RTN","DGRPD",249,0) Q "RTN","DGRPD",250,0) LANGUAGE ; Get language data *///* "RTN","DGRPD",251,0) S DGLANGDT=9999999,(DGPRFLAN,DGLANG0)="" "RTN","DGRPD",252,0) S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1) "RTN","DGRPD",253,0) I DGLANGDT="" G L1 "RTN","DGRPD",254,0) S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0)) "RTN","DGRPD",255,0) S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2) "RTN","DGRPD",256,0) S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y "RTN","DGRPD",257,0) L1 W !!,"Language Date/Time: ",$S(DGLANGDT="":"UNANSWERED",1:DGLANGDT),! "RTN","DGRPD",258,0) W ?1,"Preferred Language: ",$S(DGPRFLAN="":"UNANSWERED",1:DGPRFLAN) "RTN","DGRPD",259,0) K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA "RTN","DGRPD",260,0) Q "RTN","DGRPD",261,0) SOGI ;**1059 SOGI FIELDS TO BE DISPLAYED VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121 "RTN","DGRPD",262,0) ;**1071 VAMPI-13755 (jfw) - Display Additional SO Info "RTN","DGRPD",263,0) N EN,SXO,PRN "RTN","DGRPD",264,0) W !,"Birth Sex : ",$$GET1^DIQ(2,DFN,".02","E") "RTN","DGRPD",265,0) ;SEXUAL ORIENTATION "RTN","DGRPD",266,0) W !,"Sexual Orientation: " "RTN","DGRPD",267,0) S EN=0 F S EN=$O(^DPT(DFN,.025,EN)) Q:'EN D "RTN","DGRPD",268,0) .N DGSOI D GETS^DIQ(2.025,EN_","_DFN,"*",,"DGSOI") "RTN","DGRPD",269,0) .W !?20,DGSOI(2.025,EN_","_DFN_",",.01)_" ("_DGSOI(2.025,EN_","_DFN_",",.02)_")" "RTN","DGRPD",270,0) .W !?25,"Date Created:",?44,DGSOI(2.025,EN_","_DFN_",",.03) "RTN","DGRPD",271,0) .W !?25,"Date Last Updated: "_DGSOI(2.025,EN_","_DFN_",",.04) "RTN","DGRPD",272,0) W !,"Sexual Orientation Description: ",$$GET1^DIQ(2,DFN,".0251","E") "RTN","DGRPD",273,0) W !,"Pronoun: " "RTN","DGRPD",274,0) S EN=0 F S EN=$O(^DPT(DFN,.2406,EN)) Q:'EN D "RTN","DGRPD",275,0) .S PRN=$G(^DPT(DFN,.2406,EN,0)) "RTN","DGRPD",276,0) .W !?20,$P($G(^DG(47.78,PRN,0)),"^") "RTN","DGRPD",277,0) W !,"Pronoun Description: ",$$GET1^DIQ(2,DFN,".24061","E") "RTN","DGRPD",278,0) W !,"Self-Identified Gender Identity: ",$$GET1^DIQ(2,DFN,".024","E") "RTN","DGRPD",279,0) Q "RTN","VADPT1") 0^4^B74338795^B70654177 "RTN","VADPT1",1,0) VADPT1 ;ALB/MRL,MJK,ERC,TDM,CLT,ARF - PATIENT VARIABLES ;05 May 2017 1:41 PM "RTN","VADPT1",2,0) ;;5.3;Registration;**415,489,516,614,688,754,887,941,1059,1067,1071**;Aug 13, 1993;Build 4 "RTN","VADPT1",3,0) ; "RTN","VADPT1",4,0) 1 ;Demographic [DEM] "RTN","VADPT1",5,0) N W,Z,NODE "RTN","VADPT1",6,0) ; "RTN","VADPT1",7,0) ; -- name [1 - NM] "RTN","VADPT1",8,0) S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^") "RTN","VADPT1",9,0) ; "RTN","VADPT1",10,0) ; -- ssn [2 - SS] "RTN","VADPT1",11,0) S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"") "RTN","VADPT1",12,0) ; "RTN","VADPT1",13,0) ; -- date of birth [2 - DB] "RTN","VADPT1",14,0) S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y "RTN","VADPT1",15,0) ; "RTN","VADPT1",16,0) ; -- age [4 - AG] "RTN","VADPT1",17,0) S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) "RTN","VADPT1",18,0) ; "RTN","VADPT1",19,0) ; -- expired date [6 - EX] "RTN","VADPT1",20,0) S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y "RTN","VADPT1",21,0) ; "RTN","VADPT1",22,0) ; -- sex [5 - SX] "RTN","VADPT1",23,0) S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z "RTN","VADPT1",24,0) ; "RTN","VADPT1",25,0) ; -- remarks [7 - RE] "RTN","VADPT1",26,0) S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10) "RTN","VADPT1",27,0) ; "RTN","VADPT1",28,0) ; -- historic race [8 - RA] "RTN","VADPT1",29,0) S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",30,0) ; "RTN","VADPT1",31,0) ; -- religion [9 - RP] "RTN","VADPT1",32,0) S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",33,0) ; "RTN","VADPT1",34,0) ; -- marital status [10 - MS] "RTN","VADPT1",35,0) S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",36,0) ; "RTN","VADPT1",37,0) ; -- ethnicity [11 - ET] "RTN","VADPT1",38,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D "RTN","VADPT1",39,0) .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",40,0) ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1) "RTN","VADPT1",41,0) ..; -- collection method "RTN","VADPT1",42,0) ..S Z=$P(NODE,"^",2) I Z D "RTN","VADPT1",43,0) ...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",44,0) S @VAV@($P(VAS,"^",11))=Y-1 "RTN","VADPT1",45,0) ; "RTN","VADPT1",46,0) ; -- race [12 - RC] "RTN","VADPT1",47,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D "RTN","VADPT1",48,0) .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",49,0) ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1) "RTN","VADPT1",50,0) ..; -- collection method "RTN","VADPT1",51,0) ..S Z=$P(NODE,"^",2) I Z D "RTN","VADPT1",52,0) ...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",53,0) S @VAV@($P(VAS,"^",12))=Y-1 "RTN","VADPT1",54,0) ; "RTN","VADPT1",55,0) ; -- current pt preferred language [13 - LG] "RTN","VADPT1",56,0) N VALANGDT,VAPRFLAN,VALANG0,VAY,VALANGDA,X,Y "RTN","VADPT1",57,0) S VALANGDT=9999999,(VAPRFLAN,VALANG0)="" "RTN","VADPT1",58,0) S VALANGDT=$O(^DPT(DFN,.207,"B",VALANGDT),-1) "RTN","VADPT1",59,0) I VALANGDT="" S @VAV@($P(VAS,"^",13))="",@VAV@($P(VAS,"^",13),1)="" "RTN","VADPT1",60,0) I VALANGDT'="" D "RTN","VADPT1",61,0) .S VALANGDA=$O(^DPT(DFN,.207,"B",VALANGDT,0)) "RTN","VADPT1",62,0) .S VALANG0=$G(^DPT(DFN,.207,VALANGDA,0)),Y=$P(VALANG0,U),VAPRFLAN=$P(VALANG0,U,2) "RTN","VADPT1",63,0) .S (VAY,Y)=VALANGDT X ^DD("DD") S VALANGDT=Y "RTN","VADPT1",64,0) .S @VAV@($P(VAS,"^",13))=VAY_"^"_VALANGDT ; FM version^human readable "RTN","VADPT1",65,0) .S @VAV@($P(VAS,"^",13),1)=VALANGDA_"^"_VAPRFLAN ; Pointer^human readable "RTN","VADPT1",66,0) ; "RTN","VADPT1",67,0) ; Preferred Name [14 - NM] "RTN","VADPT1",68,0) ;**1059 Adding Sexual Orientation, Sexual Orientation Description, Pronoun, Pronoun Description, SIGI [14 - SOGI] "RTN","VADPT1",69,0) ;**1071 VAMPI-13755 (jfw) - Display Additional SO Info "RTN","VADPT1",70,0) N SOC,CNTR,PRO,SIGI,SIGIN,VAREF "RTN","VADPT1",71,0) S @VAV@($P(VAS,"^",14))="" "RTN","VADPT1",72,0) ;Sexual Orientation #.025 multiple "RTN","VADPT1",73,0) S CNTR=1,X=0 F S X=$O(^DPT(DFN,.025,X)) Q:'X!(X="") D "RTN","VADPT1",74,0) .N VASOI D GETS^DIQ(2.025,X_","_DFN,"*","EI","VASOI") "RTN","VADPT1",75,0) .;External^Internal values: SO, Status, Date Created, Date Last Updated, TIU Document "RTN","VADPT1",76,0) .S VAREF="VASOI(2.025,"""_X_","_DFN_","")",@VAV@($P(VAS,"^",14),1,CNTR)=$P($G(^DG(47.77,@VAREF@(.01,"I"),0)),"^",1,2) "RTN","VADPT1",77,0) .N VAI F VAI=.02,.03,.04,.05 S @VAV@($P(VAS,"^",14),1,CNTR,(VAI*100-1))=@VAREF@(VAI,"E")_"^"_@VAREF@(VAI,"I") "RTN","VADPT1",78,0) .S CNTR=CNTR+1 "RTN","VADPT1",79,0) S @VAV@($P(VAS,"^",14),1)=CNTR-1 "RTN","VADPT1",80,0) ;Sexual Orientatin Description #.241 "RTN","VADPT1",81,0) S @VAV@($P(VAS,"^",14),2)=$P($G(^DPT(DFN,.241)),"^") "RTN","VADPT1",82,0) ;Pronoun #.2406 multiple "RTN","VADPT1",83,0) K CNTR,X "RTN","VADPT1",84,0) S CNTR=1,X=0 F S X=$O(^DPT(DFN,.2406,X)) Q:'X!(X="") D "RTN","VADPT1",85,0) .S PRO=$G(^DPT(DFN,.2406,X,0)) "RTN","VADPT1",86,0) .S @VAV@($P(VAS,"^",14),3,CNTR)=$G(^DG(47.78,PRO,0)),CNTR=CNTR+1 ;NAME ^ CODE "RTN","VADPT1",87,0) S @VAV@($P(VAS,"^",14),3)=CNTR-1 "RTN","VADPT1",88,0) ;Pronoun Description #.24061 "RTN","VADPT1",89,0) S @VAV@($P(VAS,"^",14),4)=$P($G(^DPT(DFN,.241)),"^",2) "RTN","VADPT1",90,0) ;SELF IDENTIFIED GENDER #.024 "RTN","VADPT1",91,0) S SIGI=$P($G(^DPT(DFN,.24)),"^",4),SIGIN=$$GET1^DIQ(2,DFN_",",.024) "RTN","VADPT1",92,0) S @VAV@($P(VAS,"^",14),5)=SIGIN_"^"_SIGI ;NAME ^ CODE "RTN","VADPT1",93,0) Q "RTN","VADPT1",94,0) ; "RTN","VADPT1",95,0) 2 ;Other Patient Variables [OPD] "RTN","VADPT1",96,0) N W,Z "RTN","VADPT1",97,0) S VAX=^DPT(DFN,0) "RTN","VADPT1",98,0) ; "RTN","VADPT1",99,0) ; -- city of birth [1 - BC] "RTN","VADPT1",100,0) S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11) "RTN","VADPT1",101,0) ; "RTN","VADPT1",102,0) ; -- state of birth [2 - BS] "RTN","VADPT1",103,0) S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"") "RTN","VADPT1",104,0) ; "RTN","VADPT1",105,0) ; -- occupation [6 - OC] "RTN","VADPT1",106,0) S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7) "RTN","VADPT1",107,0) ; "RTN","VADPT1",108,0) ; -- names "RTN","VADPT1",109,0) S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"") "RTN","VADPT1",110,0) S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN] "RTN","VADPT1",111,0) S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN] "RTN","VADPT1",112,0) S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM] "RTN","VADPT1",113,0) ; "RTN","VADPT1",114,0) ; -- employment status [7 - ES] "RTN","VADPT1",115,0) S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN" "RTN","VADPT1",116,0) S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"") "RTN","VADPT1",117,0) ; "RTN","VADPT1",118,0) ; -- PHONE NUMBER [WORK] [8 - WP] "RTN","VADPT1",119,0) I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",2) "RTN","VADPT1",120,0) Q "RTN","VADPT1",121,0) ; "RTN","VADPT1",122,0) 3 ;Address [ADD] "RTN","VADPT1",123,0) N VAFOR "RTN","VADPT1",124,0) S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT) "RTN","VADPT1",125,0) I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)VAACTDT)!(VAEND&(VAEND6:1,1:0) S VAX=.21,VAOA("A")=7 "RTN","VADPT1",197,0) E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A")) "RTN","VADPT1",198,0) S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99) "RTN","VADPT1",199,0) S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",200,0) S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8 "RTN","VADPT1",201,0) F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",202,0) I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))="" "RTN","VADPT1",203,0) ;DG*5.3*1067 store the RELATION TYPE field, from the PATIENT CONTACT RELATION file(#12.11)file, into node 10 "RTN","VADPT1",204,0) ;and move RELATIONSHIP TO PATIENT to node 12 only for the Emergency Contacts, Next of Kins, and Designees options. "RTN","VADPT1",205,0) I (+VAOA("A")'=5)&(+VAOA("A")'=6) S @VAV@($P(VAS,"^",10))=$$GET1^DIQ(12.11,$P(VAX,"^",15)_",",.02),@VAV@($P(VAS,"^",12))=$P(VAX,"^",2) "RTN","VADPT1",206,0) S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1) "RTN","VADPT1",207,0) S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A")) "RTN","VADPT1",208,0) S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9)) "RTN","VADPT1",209,0) Q "RTN","VAFCAPI") 0^5^B139478624^n/a "RTN","VAFCAPI",1,0) VAFCAPI ;BIR/DRI - MVI API ENTRY POINTS ;5/18/22 09:21 "RTN","VAFCAPI",2,0) ;;5.3;Registration;**1071**;Aug 13, 1993;Build 4 "RTN","VAFCAPI",3,0) ; "RTN","VAFCAPI",4,0) ;Supports IA #7323, Private subscription "RTN","VAFCAPI",5,0) ; "RTN","VAFCAPI",6,0) ;Reference to $$DT^XLFDT supported by IA# 10103 "RTN","VAFCAPI",7,0) ;Reference to ^TIU(8925 supported by IA#3376 "RTN","VAFCAPI",8,0) ; "RTN","VAFCAPI",9,0) SOGI(DFN,ARRAY,UPDATE) ;api for cprs to update sexual orientation and gender identity trait fields ;**1071, VAMPI-13755 (dri) "RTN","VAFCAPI",10,0) ; "RTN","VAFCAPI",11,0) ; Business Rules: "RTN","VAFCAPI",12,0) ; ALL of a Patient's Sexual Orientations must be sent "RTN","VAFCAPI",13,0) ; Once defined, Sexual Orientations can NOT be deleted, the status must be updated "RTN","VAFCAPI",14,0) ; Sexual Orientation Date Created will default to today on an add "RTN","VAFCAPI",15,0) ; Sexual Orientation Date Last Updated will default to today on an add or update "RTN","VAFCAPI",16,0) ; Sexual Orientation Description added/updated when Sexual Orientation "RTN","VAFCAPI",17,0) ; of 'Other' has a Status of 'A'ctive, otherwise it's deleted. "RTN","VAFCAPI",18,0) ; "RTN","VAFCAPI",19,0) ; When a TIU NOTE is passed to be deleted: "RTN","VAFCAPI",20,0) ; If the site has received more recent sexual orientation updates the NOTE "RTN","VAFCAPI",21,0) ; is deleted and no further updating of the sexual orientation data occures. "RTN","VAFCAPI",22,0) ; If no recent sexual orientation updates have been received but previous "RTN","VAFCAPI",23,0) ; updates exist then roll back to that data "RTN","VAFCAPI",24,0) ; "RTN","VAFCAPI",25,0) ; "RTN","VAFCAPI",26,0) ;*To Add/Update a Patient's Sexual Orientation Data: "RTN","VAFCAPI",27,0) ; DFN = pointer to entry in PATIENT (#2) file (required) "RTN","VAFCAPI",28,0) ; ARRAY("SexOr",n) = sexual orientation code^status^note "RTN","VAFCAPI",29,0) ; n - counter "RTN","VAFCAPI",30,0) ; sexual orientation code - list of code(s) from the SEXUAL ORIENTATION TYPES (#47.77) file (required) "RTN","VAFCAPI",31,0) ; status - current status of the sexual orientation (A/I) (required) "RTN","VAFCAPI",32,0) ; note - note ien from the TIU DOCUMENT (#8925) file (optional) "RTN","VAFCAPI",33,0) ; ARRAY("SexOrDes") = description for the selected 'Other' sexual orientation "RTN","VAFCAPI",34,0) ; UPDATE = 1 to file data, else data is only validated (optional) "RTN","VAFCAPI",35,0) ; "RTN","VAFCAPI",36,0) ; Returns: "RTN","VAFCAPI",37,0) ; 0 - if update is successful "RTN","VAFCAPI",38,0) ; -1^error message - if unsuccessful "RTN","VAFCAPI",39,0) ; "RTN","VAFCAPI",40,0) ; Example: "RTN","VAFCAPI",41,0) ; S DFN=100006920 "RTN","VAFCAPI",42,0) ; S ARRAY("SexOr",1)="BIS^I^5" "RTN","VAFCAPI",43,0) ; S ARRAY("SexOr",2)="OTH^A" "RTN","VAFCAPI",44,0) ; S ARRAY("SexOr",3)="STH^A" "RTN","VAFCAPI",45,0) ; S ARRAY("SexOrDes")="SEXUAL ORIENTATION DESCRIPTION TEXT" "RTN","VAFCAPI",46,0) ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY) - to validate data "RTN","VAFCAPI",47,0) ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY,1) - to file data "RTN","VAFCAPI",48,0) ; "RTN","VAFCAPI",49,0) ; "RTN","VAFCAPI",50,0) ;*To Delete a Patient's TIU NOTE: "RTN","VAFCAPI",51,0) ; DFN = pointer to entry in PATIENT (#2) file (required) "RTN","VAFCAPI",52,0) ; ARRAY("Note") = pointer to entry in TIU DOCUMENT (#8925) (required) "RTN","VAFCAPI",53,0) ; UPDATE = 1 to file data, else data is only validated (optional) "RTN","VAFCAPI",54,0) ; "RTN","VAFCAPI",55,0) ; Returns: "RTN","VAFCAPI",56,0) ; 0 - if update is successful "RTN","VAFCAPI",57,0) ; -1^error message - if unsuccessful "RTN","VAFCAPI",58,0) ; "RTN","VAFCAPI",59,0) ; Example: "RTN","VAFCAPI",60,0) ; S DFN=100006920 "RTN","VAFCAPI",61,0) ; S ARRAY("Note")=2 "RTN","VAFCAPI",62,0) ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY) - to validate data "RTN","VAFCAPI",63,0) ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY,1) - to file data "RTN","VAFCAPI",64,0) ; "RTN","VAFCAPI",65,0) ; "RTN","VAFCAPI",66,0) I '$G(DFN) Q "-1^invalid DFN passed to api" "RTN","VAFCAPI",67,0) I '$D(^DPT(DFN,0)) Q "-1^entry does not exist in Patient file" "RTN","VAFCAPI",68,0) I $D(^DPT(DFN,-9)) Q "-1^merged patient" "RTN","VAFCAPI",69,0) ; "RTN","VAFCAPI",70,0) I $G(UPDATE)'=1 S UPDATE=0 ;should data be filed "RTN","VAFCAPI",71,0) ; "RTN","VAFCAPI",72,0) N TODAY "RTN","VAFCAPI",73,0) S TODAY=$$DT^XLFDT "RTN","VAFCAPI",74,0) ; "RTN","VAFCAPI",75,0) I $G(ARRAY("Note")) Q $$NOTE(DFN,.ARRAY,UPDATE) "RTN","VAFCAPI",76,0) Q $$SEXOR(DFN,.ARRAY,UPDATE) "RTN","VAFCAPI",77,0) ; "RTN","VAFCAPI",78,0) ; "RTN","VAFCAPI",79,0) SEXOR(DFN,ARRAY,UPDATE) ;process incoming sexual orientation and sexual orientation description "RTN","VAFCAPI",80,0) N CD,CUR,ERROR,FDA,INC,NOTE,RES,SEQ,STATUS,VAFCERR "RTN","VAFCAPI",81,0) S ERROR=0 "RTN","VAFCAPI",82,0) ; "RTN","VAFCAPI",83,0) ;loop through incoming sexual orientations, validate data, build list, ignore if passed with 'error' status "RTN","VAFCAPI",84,0) S SEQ=0 F S SEQ=$O(ARRAY("SexOr",SEQ)) Q:'SEQ I $P($G(ARRAY("SexOr",SEQ)),"^",2)'="E" D I ERROR Q "RTN","VAFCAPI",85,0) .S CD=$P($G(ARRAY("SexOr",SEQ)),"^",1) D CHK^DIE(2.025,.01,,CD,.RES,"VAFCERR") I RES="^" S ERROR="-1^"_$$BLDERR("VAFCERR") Q ;validate sexual orientation code "RTN","VAFCAPI",86,0) .S STATUS=$P($G(ARRAY("SexOr",SEQ)),"^",2) D CHK^DIE(2.025,.02,,STATUS,.RES,"VAFCERR") I RES="^" S ERROR="-1^"_$$BLDERR("VAFCERR") Q ;validate status "RTN","VAFCAPI",87,0) .S NOTE=$P($G(ARRAY("SexOr",SEQ)),"^",3) I NOTE'="",'$D(^TIU(8925,NOTE,0)) S ERROR="-1^Invalid TIU NOTE IEN" Q ;validate tiu note ien "RTN","VAFCAPI",88,0) .S INC(CD)=SEQ ;build incoming list "RTN","VAFCAPI",89,0) I ERROR Q ERROR "RTN","VAFCAPI",90,0) ; "RTN","VAFCAPI",91,0) ;validate sexual orientation description "RTN","VAFCAPI",92,0) I $G(ARRAY("SexOrDes"))'="" D "RTN","VAFCAPI",93,0) .D CHK^DIE(2,.0251,,ARRAY("SexOrDes"),.RES,"VAFCERR") I RES="^" S ERROR="-1^"_$$BLDERR("VAFCERR") Q "RTN","VAFCAPI",94,0) .I $S('$D(INC("OTH")):1,$P($G(ARRAY("SexOr",+$G(INC("OTH")))),"^",2)'="A":1,1:0) S ERROR="-1^Sexual Orientation of 'Other' with 'Active' Status required to update 'SO' Description" "RTN","VAFCAPI",95,0) I ERROR Q ERROR "RTN","VAFCAPI",96,0) ; "RTN","VAFCAPI",97,0) ;loop through current sexual orientations, validate data, build list "RTN","VAFCAPI",98,0) S SEQ=0 F S SEQ=$O(^DPT(DFN,.025,SEQ)) Q:'SEQ S CD=$$GET1^DIQ(47.77,+$P(^DPT(DFN,.025,SEQ,0),"^",1)_",",1) I CD'="" D I ERROR Q "RTN","VAFCAPI",99,0) .I '$D(INC(CD)),$P($G(^DPT(DFN,.025,SEQ,0)),"^",2)'="E" S ERROR="-1^Patient currently has more Sexual Orientations defined, entire list must be passed" ;errored 'so' not passed "RTN","VAFCAPI",100,0) .S CUR(CD)=SEQ ;build current list, must included 'errored' so duplicates aren't built "RTN","VAFCAPI",101,0) I ERROR Q ERROR "RTN","VAFCAPI",102,0) ; "RTN","VAFCAPI",103,0) ;loop through incoming values "RTN","VAFCAPI",104,0) S CD="" F S CD=$O(INC(CD)) Q:CD="" D "RTN","VAFCAPI",105,0) .I '$D(CUR(CD)) D ;if not in current array set fda for an add "RTN","VAFCAPI",106,0) ..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.01)=CD ;sexual orientation "RTN","VAFCAPI",107,0) ..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.02)=$P(ARRAY("SexOr",INC(CD)),"^",2) ;status "RTN","VAFCAPI",108,0) ..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.03)=TODAY ;date created "RTN","VAFCAPI",109,0) ..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.04)=TODAY ;date last updated "RTN","VAFCAPI",110,0) ..I $P(ARRAY("SexOr",INC(CD)),"^",3) S FDA(2.025,"+"_INC(CD)_","_DFN_",",.05)="`"_$P(ARRAY("SexOr",INC(CD)),"^",3) ;note "RTN","VAFCAPI",111,0) ..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.06)="L" ;type of update - 'l'ocal "RTN","VAFCAPI",112,0) .; "RTN","VAFCAPI",113,0) .I $D(CUR(CD)) D ;if in current array set fda for an update "RTN","VAFCAPI",114,0) ..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",2)'=$P(ARRAY("SexOr",INC(CD)),"^",2) S FDA(2.025,CUR(CD)_","_DFN_",",.02)=$P(ARRAY("SexOr",INC(CD)),"^",2) ;status change "RTN","VAFCAPI",115,0) ..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",3)="" S FDA(2.025,CUR(CD)_","_DFN_",",.03)=TODAY ;date created if null "RTN","VAFCAPI",116,0) ..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",4)'=TODAY S FDA(2.025,CUR(CD)_","_DFN_",",.04)=TODAY ;date last updated always updated to today "RTN","VAFCAPI",117,0) ..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",5)'=$P(ARRAY("SexOr",INC(CD)),"^",3) S FDA(2.025,CUR(CD)_","_DFN_",",.05)=$S($P(ARRAY("SexOr",INC(CD)),"^",3):"`"_$P(ARRAY("SexOr",INC(CD)),"^",3),1:"@") ;note "RTN","VAFCAPI",118,0) ..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",6)'="L" S FDA(2.025,CUR(CD)_","_DFN_",",.06)="L" ;type of update - 'l'ocal "RTN","VAFCAPI",119,0) ; "RTN","VAFCAPI",120,0) ;current business rules don't allow sexual orientation deletions for any reason "RTN","VAFCAPI",121,0) ;loop through current values, if not in incoming array set FDA to delete "RTN","VAFCAPI",122,0) ;S CD="" F S CD=$O(CUR(CD)) Q:CD="" I '$D(INC(CD)) S FDA(2.025,CUR(CD)_","_DFN_",",.01)="@" "RTN","VAFCAPI",123,0) ; "RTN","VAFCAPI",124,0) ;process sexual orientation description,set fda to add/update/delete "RTN","VAFCAPI",125,0) I '$D(INC("OTH")),$$GET1^DIQ(2,DFN_",",.0251)'="" S FDA(2,DFN_",",.0251)="@" ;delete a previously filed sexual orientation description if no 'so' of 'Other' "RTN","VAFCAPI",126,0) I $D(INC("OTH")) D "RTN","VAFCAPI",127,0) .I $P(ARRAY("SexOr",+INC("OTH")),"^",2)'="A",$$GET1^DIQ(2,DFN_",",.0251)'="" S FDA(2,DFN_",",.0251)="@" Q ;delete a previously filed sexual orientation description if status of incoming 'so' of 'Other' isn't active "RTN","VAFCAPI",128,0) .I $P(ARRAY("SexOr",+INC("OTH")),"^",2)="A",$G(ARRAY("SexOrDes"))'="",ARRAY("SexOrDes")'=$$GET1^DIQ(2,DFN_",",.0251) S FDA1(2,DFN_",",.0251)=ARRAY("SexOrDes") ;add/update sexual orientation description since 'so' of 'Other' is active "RTN","VAFCAPI",129,0) ; "RTN","VAFCAPI",130,0) I UPDATE D I ERROR Q ERROR "RTN","VAFCAPI",131,0) .I $D(FDA) S ERROR=$$UPDATE(.FDA) I ERROR Q ;file sexual orientation data "RTN","VAFCAPI",132,0) .I $D(FDA1) S ERROR=$$UPDATE(.FDA1) ;file sexual orientation description separately so 'ahist' x-ref is properly built "RTN","VAFCAPI",133,0) ; "RTN","VAFCAPI",134,0) Q ERROR "RTN","VAFCAPI",135,0) ; "RTN","VAFCAPI",136,0) ; "RTN","VAFCAPI",137,0) NOTE(DFN,ARRAY,UPDATE) ;tiu note deletion "RTN","VAFCAPI",138,0) N ERROR,FDA,FDA1,GLO,LDLUP,NOTE,PREV,SEQ,SEQL "RTN","VAFCAPI",139,0) S ERROR=0 "RTN","VAFCAPI",140,0) ; "RTN","VAFCAPI",141,0) S NOTE=ARRAY("Note") "RTN","VAFCAPI",142,0) ;I '$D(^TIU(8925,NOTE,0)) S ERROR="-1^Invalid TIU NOTE IEN" Q ;validate tiu note ien - no need to validate, could have already been deleted before calling api "RTN","VAFCAPI",143,0) S SEQ=0 F S SEQ=$O(^DPT(DFN,.025,SEQ)) Q:'SEQ I $P($G(^DPT(DFN,.025,SEQ,0)),"^",5)=NOTE S FDA(2.025,SEQ_","_DFN_",",.05)="@",SEQL(SEQ)="" ;delete note from entries, keep list of modified sequences "RTN","VAFCAPI",144,0) S GLO="^DPT(DFN,.025,""AHIST"")" F S GLO=$Q(@GLO) Q:GLO="" Q:($QS(GLO,3)'="AHIST") I $P(@GLO,"^",1)=NOTE S LDLUP=$QS(GLO,4) ;find most recent (last) date last update in history x-ref with tiu note, 'so' could already have a newer tiu note "RTN","VAFCAPI",145,0) I '$D(FDA)&'$G(LDLUP) S ERROR="-1^TIU NOTE doesn't exist in Patient's Sexual Orientation History" Q ERROR "RTN","VAFCAPI",146,0) I UPDATE,$D(FDA) S ERROR=$$UPDATE(.FDA) I ERROR Q ;delete note, let fileman fire x-ref's "RTN","VAFCAPI",147,0) I UPDATE S GLO="^DPT(DFN,.025,""AHIST"")" F S GLO=$Q(@GLO) Q:GLO="" Q:($QS(GLO,3)'="AHIST") I $P(@GLO,"^",1)=NOTE K @GLO S SEQL($QS(GLO,6))="" ;delete orphaned x-ref with a tiu note, possibly missed due to 'so' already having newer note "RTN","VAFCAPI",148,0) ; "RTN","VAFCAPI",149,0) I $G(LDLUP) D ;this is the last 'date last updated' history x-ref's removed "RTN","VAFCAPI",150,0) .I $O(^DPT(DFN,.025,"AHIST",LDLUP)) Q ;more recent history exists in x-ref so don't update anything, since all 'so's always updated, no need to look at just modified 'so's "RTN","VAFCAPI",151,0) .; "RTN","VAFCAPI",152,0) .I $O(^DPT(DFN,.025,"AHIST",LDLUP+1),-1) D ;previous history exists, possibly from another site on the same day "RTN","VAFCAPI",153,0) ..S GLO="^DPT(DFN,.025,""AHIST"",0)" F S GLO=$Q(@GLO) Q:GLO="" Q:$QS(GLO,3)'="AHIST" Q:$QS(GLO,4)>LDLUP I $QS(GLO,6),$D(SEQL($QS(GLO,6))) D ;find most recent past history for modified 'so's "RTN","VAFCAPI",154,0) ...S PREV($QS(GLO,6))=$QS(GLO,7)_"^"_$QS(GLO,8)_"^"_$QS(GLO,9)_"^"_$QS(GLO,4)_"^"_$P($G(@GLO),"^",1)_"^"_$QS(GLO,5) "RTN","VAFCAPI",155,0) ...I $QS(GLO,7)=5 S PREV($QS(GLO,6),"SexOrDes")=$P($G(@GLO),"^",2) ;only set description if 'Other' "RTN","VAFCAPI",156,0) .; "RTN","VAFCAPI",157,0) .S SEQ=0 F S SEQ=$O(SEQL(SEQ)) Q:'SEQ D ;only loop through the modified sexual orientations "RTN","VAFCAPI",158,0) ..I $D(PREV(SEQ)) D Q ;if previous updates exist, roll back to how it looked "RTN","VAFCAPI",159,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",1)'=$P(PREV(SEQ),"^",1) S FDA(2.025,SEQ_","_DFN_",",.01)=$P(PREV(SEQ),"^",1) ;sexual orientation "RTN","VAFCAPI",160,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",2)'=$P(PREV(SEQ),"^",2) S FDA(2.025,SEQ_","_DFN_",",.02)=$P(PREV(SEQ),"^",2) ;status "RTN","VAFCAPI",161,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",3)'=$P(PREV(SEQ),"^",3) S FDA(2.025,SEQ_","_DFN_",",.03)=$P(PREV(SEQ),"^",3) ;date created "RTN","VAFCAPI",162,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",4)'=$P(PREV(SEQ),"^",4) S FDA(2.025,SEQ_","_DFN_",",.04)=$P(PREV(SEQ),"^",4) ;date last updated "RTN","VAFCAPI",163,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",5)'=$P(PREV(SEQ),"^",5) S FDA(2.025,SEQ_","_DFN_",",.05)=$S($P(PREV(SEQ),"^",5):"`"_$P(PREV(SEQ),"^",5),1:"@") ;note "RTN","VAFCAPI",164,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",6)'=$P(PREV(SEQ),"^",6) S FDA(2.025,SEQ_","_DFN_",",.06)=$P(PREV(SEQ),"^",6) ;type of update "RTN","VAFCAPI",165,0) ...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",1)=5,$P($G(^DPT(DFN,.241)),"^",1)'=$P(PREV(SEQ,"SexOrDes"),"^",1) S FDA1(2,DFN_",",.0251)=$S($P(PREV(SEQ,"SexOrDes"),"^",1)'="":$P(PREV(SEQ,"SexOrDes"),"^",1),1:"@") ;update sexual orientation description "RTN","VAFCAPI",166,0) ..; "RTN","VAFCAPI",167,0) ..I '$D(PREV(SEQ)) D ;if previous updates did not exist then it was 'entered in error' "RTN","VAFCAPI",168,0) ...S FDA(2.025,SEQ_","_DFN_",",.02)="E" ;status "RTN","VAFCAPI",169,0) ...S FDA(2.025,SEQ_","_DFN_",",.04)=TODAY ;date last updated "RTN","VAFCAPI",170,0) ...S FDA(2,DFN_",",.0251)="@" ;sexual orientation description (use fda instead of fda1 so it deletes prior to the fda1 from above filing) "RTN","VAFCAPI",171,0) .; "RTN","VAFCAPI",172,0) I UPDATE D I ERROR Q ERROR "RTN","VAFCAPI",173,0) .I $D(FDA) S ERROR=$$UPDATE(.FDA) I ERROR Q "RTN","VAFCAPI",174,0) .I $D(FDA1) S ERROR=$$UPDATE(.FDA1) ;file sexual orientation description separately so 'ahist' x-ref is properly built "RTN","VAFCAPI",175,0) ; "RTN","VAFCAPI",176,0) Q ERROR "RTN","VAFCAPI",177,0) ; "RTN","VAFCAPI",178,0) UPDATE(FDA) ;call update "RTN","VAFCAPI",179,0) N VAFCERR "RTN","VAFCAPI",180,0) I '$D(FDA) Q 0 "RTN","VAFCAPI",181,0) D UPDATE^DIE("E","FDA",,"VAFCERR") "RTN","VAFCAPI",182,0) I $D(VAFCERR) Q "-1^"_$$BLDERR("VAFCERR") "RTN","VAFCAPI",183,0) Q 0 "RTN","VAFCAPI",184,0) ; "RTN","VAFCAPI",185,0) ; "RTN","VAFCAPI",186,0) BLDERR(MSGROOT) ;build error from FileMan error message array "RTN","VAFCAPI",187,0) N ERRARR,ERRMSG,I "RTN","VAFCAPI",188,0) D MSG^DIALOG("AE",.ERRARR,"","",MSGROOT) "RTN","VAFCAPI",189,0) S ERRMSG="",I=0 F S I=$O(ERRARR(I)) Q:'I S ERRMSG=ERRMSG_$S(ERRMSG]"":" ",1:"")_$G(ERRARR(I)) "RTN","VAFCAPI",190,0) Q ERRMSG "RTN","VAFCAPI",191,0) ; "RTN","VAFCAPI",192,0) ; "RTN","VAFCAPI",193,0) SETSO ;set logic for 'AHIST' x-ref of Sexual Orientation Multiple (#.025) in Patient (#2) file "RTN","VAFCAPI",194,0) I $S(X(2)="E":0,X(5)=""&(X1(5)'=""):0,1:1),X(1)'="",X(2)'="",X(3)'="",X(4)'="",X(6)'="" D ;only set history when 'so' has a 'non-errored' status or tiu note not being deleted "RTN","VAFCAPI",195,0) .S ^DPT(DA(1),.025,"AHIST",X(4),X(6),DA,X(1),X(2),X(3))=$S(X(6)="L":X(5),1:"") ;only local updates can have tiu notes "RTN","VAFCAPI",196,0) Q "RTN","VAFCAPI",197,0) ; "RTN","VAFCAPI",198,0) KILLSO ;kill logic for 'AHIST' x-ref of Sexual Orientation Multiple (#.025) in Patient (#2) file "RTN","VAFCAPI",199,0) I $S(X(2)'=""&(X2(2)="E"):1,X(4)'=""&(X2(4)'="")&(X2(4))="" "RTN","VAFCCRNR",11,0) ; VAFCRTN - 1 upon processing completed (*Required by Ref.) "RTN","VAFCCRNR",12,0) ; Additional Error Info - VAFCRTN(<#>)=Station# ^ Error Code ^ Error Message "RTN","VAFCCRNR",13,0) UPDT(VAFCARY,VAFCRTN) ;Add/Update EHRM MIGRATED FACILITIES (#391.919) records "RTN","VAFCCRNR",14,0) N VAFCSN,VAFCSITE,VAFCRSLT "RTN","VAFCCRNR",15,0) ;Remove CERNER ENABLED? Flag if site is no longer using the application "RTN","VAFCCRNR",16,0) S VAFCSN=0 F S VAFCSN=$O(^DGCN(391.919,"ACRNR",VAFCSN)) Q:'+VAFCSN D "RTN","VAFCCRNR",17,0) .D:('($D(VAFCARY(VAFCSN)))) "RTN","VAFCCRNR",18,0) ..S VAFCRSLT=$$OFFCRNR($$IEN^XUAF4(VAFCSN)) "RTN","VAFCCRNR",19,0) ..S:(VAFCRSLT'=1) VAFCRTN(VAFCSN)=VAFCRSLT "RTN","VAFCCRNR",20,0) ;Add/Update Facility entries that have migrated to CERNER if applicable "RTN","VAFCCRNR",21,0) S VAFCSN=0 F S VAFCSN=$O(VAFCARY(VAFCSN)) Q:'+VAFCSN D "RTN","VAFCCRNR",22,0) .D:('($D(^DGCN(391.919,"ACRNR",VAFCSN)))) "RTN","VAFCCRNR",23,0) ..S VAFCRSLT=$$ONCRNR($$IEN^XUAF4(VAFCSN)) "RTN","VAFCCRNR",24,0) ..S:(VAFCRSLT'=1) VAFCRTN(VAFCSN)=VAFCSN_"^"_VAFCRSLT "RTN","VAFCCRNR",25,0) S VAFCRTN=1 "RTN","VAFCCRNR",26,0) Q "RTN","VAFCCRNR",27,0) ; "RTN","VAFCCRNR",28,0) ;Input: VAFCSIEN - IEN of the Facility to Add/Update "RTN","VAFCCRNR",29,0) ;Output: 1 if Successful or ErrorCode ^ Error Message "RTN","VAFCCRNR",30,0) ONCRNR(VAFCSIEN) ;Update EHRM MIGRATED FACILITIES (#391.919) entry to show site migrated to CERNER "RTN","VAFCCRNR",31,0) N VAFCFDA,VAFCEMSG,VAFCEXST,VAFCFIEN "RTN","VAFCCRNR",32,0) Q:(VAFCSIEN="") "^IEN for Station Number is NOT known!" "RTN","VAFCCRNR",33,0) S VAFCEXST=$D(^DGCN(391.919,"B",VAFCSIEN)) "RTN","VAFCCRNR",34,0) ;Add new facility entry to the file "RTN","VAFCCRNR",35,0) D:('VAFCEXST) "RTN","VAFCCRNR",36,0) .S VAFCFDA(391.919,"+1,",.01)=VAFCSIEN "RTN","VAFCCRNR",37,0) .S VAFCFDA(391.919,"+1,",.02)=1 "RTN","VAFCCRNR",38,0) .S VAFCFIEN(1)=VAFCSIEN ;.01 is DINUMED to Site IEN. "RTN","VAFCCRNR",39,0) .D UPDATE^DIE("","VAFCFDA","VAFCFIEN","VAFCEMSG") "RTN","VAFCCRNR",40,0) ;Updating existing facility entry in the file "RTN","VAFCCRNR",41,0) D:(VAFCEXST) "RTN","VAFCCRNR",42,0) .S VAFCFDA(391.919,VAFCSIEN_",",.02)=1 "RTN","VAFCCRNR",43,0) .D FILE^DIE("K","VAFCFDA","VAFCEMSG") "RTN","VAFCCRNR",44,0) Q $S('$D(VAFCEMSG):1,1:$G(VAFCEMSG("DIERR",1))_"^"_$G(VAFCEMSG("DIERR",1,"TEXT",1))) "RTN","VAFCCRNR",45,0) ; "RTN","VAFCCRNR",46,0) ;Input: VAFCSIEN - IEN of the Facility to Update "RTN","VAFCCRNR",47,0) ;Output: 1 if Successful or ErrorCode ^ Error Message "RTN","VAFCCRNR",48,0) OFFCRNR(VAFCSIEN) ;Set CERNER ENABLED? field to NO for Site "RTN","VAFCCRNR",49,0) N VAFCFDA,VAFCEMSG "RTN","VAFCCRNR",50,0) Q:(VAFCSIEN="") "^IEN for Station Number is NOT known!" "RTN","VAFCCRNR",51,0) S VAFCFDA(391.919,VAFCSIEN_",",.02)=0 "RTN","VAFCCRNR",52,0) D FILE^DIE("K","VAFCFDA","VAFCEMSG") "RTN","VAFCCRNR",53,0) Q $S('$D(VAFCEMSG):1,1:$G(VAFCEMSG("DIERR",1))_"^"_$G(VAFCEMSG("DIERR",1,"TEXT",1))) "RTN","VAFCCRNR",54,0) ; "RTN","VAFCCRNR",55,0) CRNRSITE(VAFCSTNUM) ;is site cerner enabled ;**1050, VAMPI-10038 (dri) "RTN","VAFCCRNR",56,0) ;Input: "RTN","VAFCCRNR",57,0) ; VAFCSTNUM - station number to check "RTN","VAFCCRNR",58,0) ; "RTN","VAFCCRNR",59,0) ;Output; "RTN","VAFCCRNR",60,0) ; 0 - not cerner enabled "RTN","VAFCCRNR",61,0) ; 1 - cerner enabled "RTN","VAFCCRNR",62,0) ; "RTN","VAFCCRNR",63,0) I $G(VAFCSTNUM)'="",$O(^DGCN(391.919,"ACRNR",VAFCSTNUM,0)) Q 1 "RTN","VAFCCRNR",64,0) Q 0 "RTN","VAFCCRNR",65,0) ; "RTN","VAFCCRNR",66,0) GCRNSITE() ;Return the CERNER Station Number configured for this VistA Instance "RTN","VAFCCRNR",67,0) ;**1071 VAMPI-13671 (dri) new api for VistA consumers needed due to cerner cert/mock accounts "RTN","VAFCCRNR",68,0) N CRNIEN,CRNSITE "RTN","VAFCCRNR",69,0) S CRNIEN=$O(^MPIF(984.8,"B","FOUR",0)) I CRNIEN S CRNSITE=$P($G(^MPIF(984.8,CRNIEN,0)),"^",5) "RTN","VAFCCRNR",70,0) I $G(CRNSITE)="" S CRNSITE="200CRNR" "RTN","VAFCCRNR",71,0) Q CRNSITE "RTN","VAFCCRNR",72,0) ; "RTN","VAFCCRNR",73,0) ISCRNPAT(DGDFN) ;Is this a Cerner patient (i.e., is 200CRNR in the TFL)? "RTN","VAFCCRNR",74,0) ;**1071 VAMPI-13671 (dri) new api for VistA consumers needed due to cerner cert/mock accounts "RTN","VAFCCRNR",75,0) ;Input: "RTN","VAFCCRNR",76,0) ; DGDFN - pointer to PATIENT (#2) file "RTN","VAFCCRNR",77,0) ; "RTN","VAFCCRNR",78,0) ;Return: "RTN","VAFCCRNR",79,0) ; 1 - yes, 0 - no "RTN","VAFCCRNR",80,0) ; "RTN","VAFCCRNR",81,0) N DGRES,DGOUT,DGSITE,DGKEY,DGI "RTN","VAFCCRNR",82,0) S DGRES=0 "RTN","VAFCCRNR",83,0) S DGSITE=$P($$SITE^VASITE,U,3) "RTN","VAFCCRNR",84,0) S DGKEY=DGDFN_U_"PI"_U_"USVHA"_U_DGSITE "RTN","VAFCCRNR",85,0) D TFL^VAFCTFU2(.DGOUT,DGKEY) "RTN","VAFCCRNR",86,0) S DGI=0 F S DGI=$O(DGOUT(DGI)) Q:DGI="" I $P(DGOUT(DGI),U,4)=$$GCRNSITE(),$P(DGOUT(DGI),U,2)="PI" S DGRES=1 Q "RTN","VAFCCRNR",87,0) Q DGRES "RTN","VAFCCRNR",88,0) ; "RTN","VAFCPDAT") 0^1^B88865297^B83449271 "RTN","VAFCPDAT",1,0) VAFCPDAT ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 7/12/16 11:11am "RTN","VAFCPDAT",2,0) ;;5.3;Registration;**333,414,474,505,707,712,837,863,876,902,926,937,950,1059,1071**;Aug 13, 1993;Build 4 "RTN","VAFCPDAT",3,0) ;Registration has IA #3299 for MPI/PD to call START^VAFCPDAT "RTN","VAFCPDAT",4,0) ; "RTN","VAFCPDAT",5,0) ;variable DFN is not NEWed or KILLed in this routine as that variable is passed in "RTN","VAFCPDAT",6,0) ; "RTN","VAFCPDAT",7,0) MAIN ; Entry point with device call "RTN","VAFCPDAT",8,0) S NOTRPC=1 "RTN","VAFCPDAT",9,0) K ZTSAVE S ZTSAVE("DFN")="" "RTN","VAFCPDAT",10,0) D EN^XUTMDEVQ("START^VAFCPDAT","Print MPI/PD Patient Data",.ZTSAVE) "RTN","VAFCPDAT",11,0) K NOTRPC "RTN","VAFCPDAT",12,0) Q "RTN","VAFCPDAT",13,0) ; "RTN","VAFCPDAT",14,0) START ;Entry point without device call, used for RPC calls "RTN","VAFCPDAT",15,0) N X S X="MPIF001" X ^%ZOSF("TEST") I '$T W !,"MPI not installed." G QUIT ;**863 - MVI_2351 (ptd) "RTN","VAFCPDAT",16,0) S $P(LN,"=",80)="",$P(LN2,"=",60)="",QFLG=0 "RTN","VAFCPDAT",17,0) D NOW^%DTC S HDT=$$FMTE^XLFDT($E(%,1,12)) "RTN","VAFCPDAT",18,0) S SITE=$$SITE^VASITE(),SITENAM=$P(SITE,"^",2),SITENUM=$P(SITE,"^",3),SITEIEN=$P(SITE,"^") "RTN","VAFCPDAT",19,0) I +DFN<0 D Q "RTN","VAFCPDAT",20,0) .I $D(NOTRPC) W @IOF,!," " "RTN","VAFCPDAT",21,0) .W !,"ICN ",$G(ICN)," does not exist at ",SITENAM,"." "RTN","VAFCPDAT",22,0) .W !,"Search date: ",HDT,!,LN "RTN","VAFCPDAT",23,0) S DIC=2,DR=".01;.02;.03;.09;.111;.112;.113;.114;.115;.1112;.131;.132;.134;.313;.351;994;.0907;.0906;.121;.1171;.1172;.1173;" "RTN","VAFCPDAT",24,0) S DR=DR_".024;.352;.353;.354;.355;.357;.358;.2405;.025;.0251;.2406;.24061;991.11;.1151;.1152;.1153;.1154;.1155;.1156;.11571;.11572;.11573" "RTN","VAFCPDAT",25,0) S DA=DFN,DIQ(0)="EI",DIQ="DNODE" D EN^DIQ1 K DIC,DR,DA,DIQ ;**707,712,863,876;1059 "RTN","VAFCPDAT",26,0) N NAME,SSN,DOB,SEX,CLAIM,DOD,ICN,STR1,STR2,STR3,CTY,ST,ZIP,PHN,WPHN,CPHN,MBI,SSNVER,PREAS,BAI,TIN,FIN,COUNTRY,CCODE,CNAME,PROVINCE,POSTCODE,SIGEN ;**707,712,837,863,876 "RTN","VAFCPDAT",27,0) N DODD,DODENTBY,DODSRC,DODLUPD,DODLEBY,DODOPT,REST1,REST2,REST3,RESCTY,RESST,RESZP,RESP,RESPC,RESCN,ITIN,SXOD,SXO,PRN,PRND,EN,RCCODE,RCNAME ;**926 Story 323009 (ckn) **1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121 "RTN","VAFCPDAT",28,0) S NAME=$G(DNODE(2,DFN,.01,"E")),SSN=$G(DNODE(2,DFN,.09,"E")),SSNVER=$G(DNODE(2,DFN,.0907,"E")) ;**707 "RTN","VAFCPDAT",29,0) S DOB=$$FMTE^XLFDT($G(DNODE(2,DFN,.03,"I"))) "RTN","VAFCPDAT",30,0) S MBI=$G(DNODE(2,DFN,994,"I")),MBI=$S(MBI="Y":"YES",MBI="N":"NO",1:"NULL") ;**707 "RTN","VAFCPDAT",31,0) S SEX=$G(DNODE(2,DFN,.02,"E")),SIGEN=$G(DNODE(2,DFN,.024,"E")),DOD=$G(DNODE(2,DFN,.351,"E")) ;**876 - MVI_3432 (cml) "RTN","VAFCPDAT",32,0) S CLAIM=$G(DNODE(2,DFN,.313,"E")) S:CLAIM="" CLAIM="None" "RTN","VAFCPDAT",33,0) S BAI=$G(DNODE(2,DFN,.121,"E")) ;**712 "RTN","VAFCPDAT",34,0) S STR1=$G(DNODE(2,DFN,.111,"E")),STR2=$G(DNODE(2,DFN,.112,"E")),STR3=$G(DNODE(2,DFN,.113,"E")) "RTN","VAFCPDAT",35,0) S CTY=$G(DNODE(2,DFN,.114,"E")),ST=$G(DNODE(2,DFN,.115,"E")),ZIP=$G(DNODE(2,DFN,.1112,"E")) "RTN","VAFCPDAT",36,0) S COUNTRY=$G(DNODE(2,DFN,.1173,"I")),(CCODE,CNAME)="" I COUNTRY]"" S CCODE=$$GET1^DIQ(779.004,+COUNTRY_",",.01),CNAME=$$GET1^DIQ(779.004,+COUNTRY_",",1.3) ;**863 - MVI_1902 (ptd) "RTN","VAFCPDAT",37,0) S PROVINCE=$G(DNODE(2,DFN,.1171,"E")),POSTCODE=$G(DNODE(2,DFN,.1172,"E")) "RTN","VAFCPDAT",38,0) ;**1071 Story 13802 (jfw) - Retrieve/Display WorkPhone (.132) and CellPhone (.134) "RTN","VAFCPDAT",39,0) S PHN=$G(DNODE(2,DFN,.131,"E")),WPHN=$G(DNODE(2,DFN,.132,"E")),CPHN=$G(DNODE(2,DFN,.134,"E")),PREAS=$G(DNODE(2,DFN,.0906,"E")) ;**707 "RTN","VAFCPDAT",40,0) S MNODE=$$MPINODE^MPIFAPI(DFN) I +MNODE=-1 S MNODE="^^^^^^^^" "RTN","VAFCPDAT",41,0) S (ICN,SCN,SCORE,SCRDT,DIFF,TIN,FIN)="" ;**837, MVI_883 "RTN","VAFCPDAT",42,0) S ICN=$$GETICN^MPIF001(DFN) S:(+ICN=-1) ICN="None" ;**863 - MVI_2351 (ptd) "RTN","VAFCPDAT",43,0) ;**926 - Story 323009 (ckn): DOD fields "RTN","VAFCPDAT",44,0) I DOD'="" D "RTN","VAFCPDAT",45,0) .;Date of Death Entered By ;Date of Death Source of Notification ;Date of Death Last Updated ;Date of Death Last Edited By ;Date of Death Supporting Document Type ;Date of Death Option Used "RTN","VAFCPDAT",46,0) . S DODENTBY=$G(DNODE(2,DFN,.352,"E")),DODSRC=$G(DNODE(2,DFN,.353,"E")),DODLUPD=$G(DNODE(2,DFN,.354,"E")),DODLEBY=$G(DNODE(2,DFN,.355,"E")) "RTN","VAFCPDAT",47,0) . S DODD=$G(DNODE(2,DFN,.357,"E")),DODOPT=$G(DNODE(2,DFN,.358,"E")) "RTN","VAFCPDAT",48,0) ;S CMOR=$$GET1^DIQ(4,+$P($G(MNODE),"^",3)_",",.01) S:CMOR="" CMOR="None" ;removed for **837, MVI_918 "RTN","VAFCPDAT",49,0) I $E(ICN,1,3)=SITENUM S GOT=0 I $P($G(MNODE),"^",4)=""!('$D(^DPT("AICNL",1,DFN))) S ICN=ICN_"**" "RTN","VAFCPDAT",50,0) S TIN=$P($G(MNODE),"^",8),FIN=$P($G(MNODE),"^",9) ;**837, MVI_883 "RTN","VAFCPDAT",51,0) ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121 "RTN","VAFCPDAT",52,0) S REST1=$G(DNODE(2,DFN,.1151,"E")),REST2=$G(DNODE(2,DFN,.1152,"E")),REST3=$G(DNODE(2,DFN,.1153,"E")),RESCTY=$G(DNODE(2,DFN,.1154,"E")),RESST=$G(DNODE(2,DFN,.1155,"E")) "RTN","VAFCPDAT",53,0) S RESZP=$G(DNODE(2,DFN,.1156,"E")),RESP=$G(DNODE(2,DFN,.11571,"E")),RESPC=$G(DNODE(2,DFN,.11572,"E")) "RTN","VAFCPDAT",54,0) S RESCN=$G(DNODE(2,DFN,.11573,"I")),(RCCODE,RCNAME)="" I RESCN]"" S RCCODE=$$GET1^DIQ(779.004,+RESCN_",",.01),RCNAME=$$GET1^DIQ(779.004,+RESCN_",",1.3) "RTN","VAFCPDAT",55,0) S ITIN=$G(DNODE(2,DFN,991.11,"E")),SXOD=$G(DNODE(2,DFN,.0251,"E")),PRND=$G(DNODE(2,DFN,.24061,"E")) "RTN","VAFCPDAT",56,0) ; "RTN","VAFCPDAT",57,0) I $D(NOTRPC) W @IOF,! "RTN","VAFCPDAT",58,0) W !,"MPI/PD Data for: ",NAME," (DFN #",DFN,")" "RTN","VAFCPDAT",59,0) ; check for patient sensitivity and user security "RTN","VAFCPDAT",60,0) N RESULT,RGSENS,SENSTV,DA,DR,DIC,DIQ,VAFCSEN "RTN","VAFCPDAT",61,0) D PTSEC^DGSEC4(.RESULT,DFN,0,"MPI/PD Patient Inquiry^MPI/PD Patient Inquiry") "RTN","VAFCPDAT",62,0) I RESULT(1)=-1 W !!,"Access denied: Required parameters not defined" G QUIT "RTN","VAFCPDAT",63,0) I RESULT(1)>0 W ?50,"***PATIENT MARKED SENSITIVE***" "RTN","VAFCPDAT",64,0) I RESULT(1)=3 W !!,"Access not allowed on your own PATIENT (#2) file entry" G QUIT "RTN","VAFCPDAT",65,0) I RESULT(1)=4 W !!,"Access denied: Your SSN is not defined" G QUIT "RTN","VAFCPDAT",66,0) I RESULT(1)<3 D "RTN","VAFCPDAT",67,0) . I RESULT(1)=1 D NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",2) ;IA #3027 "RTN","VAFCPDAT",68,0) . I RESULT(1)=2 D NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",3) ;IA #3027 "RTN","VAFCPDAT",69,0) W !,"Printed ",HDT," at ",SITENAM,!,LN "RTN","VAFCPDAT",70,0) S $Y=$Y+1 "RTN","VAFCPDAT",71,0) ;next 7 lines modified for **707 "RTN","VAFCPDAT",72,0) W !,"ICN : ",ICN ;CMOR removed **837, MVI_918 "RTN","VAFCPDAT",73,0) W !,"SSN : ",SSN "RTN","VAFCPDAT",74,0) I SSNVER'="" W !?9,"SSN Verification Status: ",SSNVER "RTN","VAFCPDAT",75,0) I PREAS'="" W !?9,"Pseudo SSN Reason: ",PREAS "RTN","VAFCPDAT",76,0) I ITIN'="" W !?9,"Individual Tax ID: ",ITIN ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121 "RTN","VAFCPDAT",77,0) ; Story 603957 (elz) change sex to birth sex, lined up with DOB and DOD at the same time "RTN","VAFCPDAT",78,0) W !,"Birth Sex : ",SEX "RTN","VAFCPDAT",79,0) ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121 "RTN","VAFCPDAT",80,0) ;**1071 VAMPI-13755 (jfw) - Display additional SO Info "RTN","VAFCPDAT",81,0) ;SEXUAL ORIENTATION "RTN","VAFCPDAT",82,0) I $O(^DPT(DFN,.025,0))'="" W !,"Sexual Orientation: " D "RTN","VAFCPDAT",83,0) .S EN=0 F S EN=$O(^DPT(DFN,.025,EN)) Q:'EN D "RTN","VAFCPDAT",84,0) ..N VAFCSOI D GETS^DIQ(2.025,EN_","_DFN,"*",,"VAFCSOI") "RTN","VAFCPDAT",85,0) ..W ?20,VAFCSOI(2.025,EN_","_DFN_",",.01)_" ("_VAFCSOI(2.025,EN_","_DFN_",",.02)_")" "RTN","VAFCPDAT",86,0) ..W !?25,"Date Created: ",?44,VAFCSOI(2.025,EN_","_DFN_",",.03) "RTN","VAFCPDAT",87,0) ..W !?25,"Date Last Updated: "_VAFCSOI(2.025,EN_","_DFN_",",.04) "RTN","VAFCPDAT",88,0) ..W:(+$O(^DPT(DFN,.025,EN))) ! "RTN","VAFCPDAT",89,0) I SXOD'="" W !,"Sexual Orientation Description: ",SXOD "RTN","VAFCPDAT",90,0) ;PRONOUN "RTN","VAFCPDAT",91,0) I $O(^DPT(DFN,.2406,0))'="" W !,"Pronoun: " D "RTN","VAFCPDAT",92,0) .S EN=0 F S EN=$O(^DPT(DFN,.2406,EN)) Q:'EN D "RTN","VAFCPDAT",93,0) ..S PRN=$G(^DPT(DFN,.2406,EN,0)) "RTN","VAFCPDAT",94,0) ..W ?20,$P($G(^DG(47.78,PRN,0)),"^") W:(+$O(^DPT(DFN,.2406,EN))) ! "RTN","VAFCPDAT",95,0) I PRND'="" W !,"Pronoun Description: ",PRND "RTN","VAFCPDAT",96,0) I SIGEN'="" W !,"Self-Identified Gender Identity: ",SIGEN ;**876 - MVI_3432 (cml) **902 - MVI_4730 (cml) MOVED HERE IN 1059 "RTN","VAFCPDAT",97,0) W !,"Claim # : ",CLAIM "RTN","VAFCPDAT",98,0) W !,"Date of Birth: ",DOB "RTN","VAFCPDAT",99,0) ;**926 - Story 323009 (ckn): DOD fields "RTN","VAFCPDAT",100,0) I DOD]"" D "RTN","VAFCPDAT",101,0) . W !,"Date of Death: ",DOD "RTN","VAFCPDAT",102,0) . I DODENTBY]"" W !,?15,"Entered By: ",?42,DODENTBY "RTN","VAFCPDAT",103,0) . I DODSRC]"" W !,?15,"Source of Notification: ",?42,DODSRC "RTN","VAFCPDAT",104,0) . I DODLUPD]"" W !,?15,"Last Updated: ",?42,DODLUPD "RTN","VAFCPDAT",105,0) . I DODLEBY]"" W !,?15,"Last Edited By: ",?42,DODLEBY "RTN","VAFCPDAT",106,0) . I DODD]"" W !,?15,"Supporting Document Type: ",?42,DODD "RTN","VAFCPDAT",107,0) . I DODOPT]"" W !,?15,"Option Used: ",?42,DODOPT "RTN","VAFCPDAT",108,0) I MBI]"" W !,"Multiple Birth Indicator: ",MBI ;**707 "RTN","VAFCPDAT",109,0) I TIN]"" W !,"DoD Temporary ID Number : ",TIN ;**837, MVI_883 "RTN","VAFCPDAT",110,0) I FIN]"" W !,"DoD Foreign ID Number : ",FIN ;**837, MVI_883 "RTN","VAFCPDAT",111,0) W !,"Correspondence Address:" I BAI'="" W " (Bad Address Indicator: ",BAI,")" ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121 "RTN","VAFCPDAT",112,0) I STR1'="" W !?9,STR1 "RTN","VAFCPDAT",113,0) I STR2'="" W !?9,STR2 "RTN","VAFCPDAT",114,0) I STR3'="" W !?9,STR3 "RTN","VAFCPDAT",115,0) I COUNTRY=""!(CCODE="USA") D ;USA Address **863 - MVI_1902 (ptd) "RTN","VAFCPDAT",116,0) .I CTY]"" W !?9,$E(CTY,1,20)_", "_$G(ST)_" "_$G(ZIP) "RTN","VAFCPDAT",117,0) I COUNTRY]"",CCODE'="USA" D ;Foreign Address "RTN","VAFCPDAT",118,0) .I CTY]""!(PROVINCE]"")!(POSTCODE]"") D "RTN","VAFCPDAT",119,0) ..I PROVINCE]"" W !?9,CTY_", "_PROVINCE_" ("_CNAME_") "_POSTCODE "RTN","VAFCPDAT",120,0) ..I PROVINCE="" W !?9,CTY_", "_"("_CNAME_") "_POSTCODE "RTN","VAFCPDAT",121,0) W !,"Residential Address: " "RTN","VAFCPDAT",122,0) I REST1'="" W !?9,REST1 "RTN","VAFCPDAT",123,0) I REST2'="" W !?9,REST2 "RTN","VAFCPDAT",124,0) I REST3'="" W !?9,REST3 "RTN","VAFCPDAT",125,0) I $G(RESCN)=""!($G(RCCODE)="USA") I RESCTY]"" W !?9,$E(RESCTY,1,20)_", "_$G(RESST)_" "_$G(RESZP) "RTN","VAFCPDAT",126,0) I RESCN'="",$G(RCCODE)'="USA" D ;Foreign Address "RTN","VAFCPDAT",127,0) .I RESCTY]""!(RESP]"")!(RESPC]"") D "RTN","VAFCPDAT",128,0) ..I RESP]"" W !?9,RESCTY_", "_RESP_" ("_RCNAME_") "_RESPC "RTN","VAFCPDAT",129,0) ..I RESP="" W !?9,RESCTY_", "_"("_RCNAME_") "_RESPC "RTN","VAFCPDAT",130,0) I PHN'="" W !,"Phone #: ",PHN "RTN","VAFCPDAT",131,0) ;**1071 Story 13802 (jfw) - Retrieve/Display WorkPhone (.132) and CellPhone (.134) "RTN","VAFCPDAT",132,0) I WPHN'="" W !,"Work #: ",WPHN "RTN","VAFCPDAT",133,0) I CPHN'="" W !,"Cell #: ",CPHN "RTN","VAFCPDAT",134,0) I $G(IOSL)<30&($E(IOST,1,2)="C-") D "RTN","VAFCPDAT",135,0) .I $Y>23 D "RTN","VAFCPDAT",136,0) ..S DIR(0)="E" D D ^DIR K DIR I 'Y S QFLG=1 "RTN","VAFCPDAT",137,0) ...S SS=22-$Y F JJ=1:1:SS W ! "RTN","VAFCPDAT",138,0) ..S $Y=0 "RTN","VAFCPDAT",139,0) I QFLG=1 G QUIT "RTN","VAFCPDAT",140,0) ; "RTN","VAFCPDAT",141,0) TF ;List Treating Facilities for this patient "RTN","VAFCPDAT",142,0) D TFHDR "RTN","VAFCPDAT",143,0) K TFARR "RTN","VAFCPDAT",144,0) S TF=0 F S TF=$O(^DGCN(391.91,"APAT",DFN,TF)) Q:'TF D "RTN","VAFCPDAT",145,0) .S TFIEN=$O(^DGCN(391.91,"APAT",DFN,TF,0)) "RTN","VAFCPDAT",146,0) . S DIC="^DGCN(391.91,",DR=".02;.03;.07",DA=TFIEN,DIQ(0)="EI",DIQ="TFDATA" "RTN","VAFCPDAT",147,0) . D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDAT",148,0) . S INST="",STATION="" "RTN","VAFCPDAT",149,0) . S INST=$G(TFDATA(391.91,TFIEN,.02,"I")) "RTN","VAFCPDAT",150,0) . I INST'="" D "RTN","VAFCPDAT",151,0) .. S DIC=4,DR="99",DA=INST,DIQ(0)="E",DIQ="STA" "RTN","VAFCPDAT",152,0) .. D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDAT",153,0) .. S STATION=$G(STA(4,INST,99,"E")) "RTN","VAFCPDAT",154,0) . S TFNM=$G(TFDATA(391.91,TFIEN,.02,"E")) "RTN","VAFCPDAT",155,0) . S LSTDT=$G(TFDATA(391.91,TFIEN,.03,"I")) S:LSTDT="" LSTDT="none found" "RTN","VAFCPDAT",156,0) . S LSTSORT=9999999 "RTN","VAFCPDAT",157,0) . I +LSTDT S LSTSORT=9999999-LSTDT,LSTDT=$$FMTE^XLFDT($E(LSTDT,1,12)) "RTN","VAFCPDAT",158,0) . S REACODE=$G(TFDATA(391.91,TFIEN,.07,"E")) S REASON="none found" "RTN","VAFCPDAT",159,0) . I REACODE'="" D "RTN","VAFCPDAT",160,0) .. S DIC="^VAT(391.72,",DIC(0)="Z",X=REACODE D ^DIC K DIC,X "RTN","VAFCPDAT",161,0) .. S REASON=$P($G(Y(0)),"^",4) "RTN","VAFCPDAT",162,0) . S TFARR(LSTSORT,TFNM)=TFIEN_"^"_REASON_"^"_$G(STATION)_"^"_LSTDT "RTN","VAFCPDAT",163,0) I '$D(TFARR) W !,"No Treating Facilities found." G SUB "RTN","VAFCPDAT",164,0) S LSTSORT=0 F S LSTSORT=$O(TFARR(LSTSORT)) Q:'LSTSORT D G:QFLG QUIT "RTN","VAFCPDAT",165,0) .S TFNM="" F S TFNM=$O(TFARR(LSTSORT,TFNM)) Q:TFNM="" D Q:QFLG "RTN","VAFCPDAT",166,0) ..S REASON=$P(TFARR(LSTSORT,TFNM),"^",2) "RTN","VAFCPDAT",167,0) ..S STATION=$P(TFARR(LSTSORT,TFNM),"^",3) "RTN","VAFCPDAT",168,0) ..S LSTDT=$P(TFARR(LSTSORT,TFNM),"^",4) "RTN","VAFCPDAT",169,0) ..I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDAT",170,0) ...S LNQ=22 D SS Q:QFLG "RTN","VAFCPDAT",171,0) ...W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D TFHDR "RTN","VAFCPDAT",172,0) ..W !,$E(TFNM,1,20),?22,$G(STATION),?32,LSTDT,?54,REASON "RTN","VAFCPDAT",173,0) SUB ;removed listing of subscribers for RG*1.0*23 "RTN","VAFCPDAT",174,0) HIS ;find ICN history "RTN","VAFCPDAT",175,0) I '$O(^DPT(DFN,"MPIFHIS",0)) G CONT "RTN","VAFCPDAT",176,0) ; "RTN","VAFCPDAT",177,0) I $Y+4>IOSL&($E(IOST,1,2)="C-") D G:QFLG QUIT "RTN","VAFCPDAT",178,0) .S LNQ=22 D SS Q:QFLG "RTN","VAFCPDAT",179,0) .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDAT",180,0) D ICNHDR "RTN","VAFCPDAT",181,0) S HIS=0 F S HIS=$O(^DPT(DFN,"MPIFHIS",HIS)) Q:'HIS D G:QFLG QUIT "RTN","VAFCPDAT",182,0) .S DIC=2,DR="992",DR(2.0992)=".01;1;3",DA=DFN,DA(2.0992)=HIS ;**863 - MVI_2351 (ptd) "RTN","VAFCPDAT",183,0) .S DIQ(0)="E",DIQ="HISNODE" "RTN","VAFCPDAT",184,0) .D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDAT",185,0) .S HISICN=$G(HISNODE(2.0992,HIS,.01,"E")) "RTN","VAFCPDAT",186,0) .S HISCHK=$G(HISNODE(2.0992,HIS,1,"E")) ;**863 - MVI_2351 (ptd) history checksum "RTN","VAFCPDAT",187,0) .S HFULLICN=HISICN_$S(HISCHK]"":"V"_HISCHK,1:"") ;**863 - MVI_2351 (ptd) History full ICN "RTN","VAFCPDAT",188,0) .S HISDT=$G(HISNODE(2.0992,HIS,3,"E")) "RTN","VAFCPDAT",189,0) .I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDAT",190,0) ..S LNQ=22 D SS Q:QFLG "RTN","VAFCPDAT",191,0) ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D ICNHDR "RTN","VAFCPDAT",192,0) .W !,HFULLICN I HISDT]"" W " - changed ",HISDT ;**863 - MVI_2351 (ptd) "RTN","VAFCPDAT",193,0) ; "RTN","VAFCPDAT",194,0) CONT ;Continue to VAFCPDT2 for extended data "RTN","VAFCPDAT",195,0) ;D CMORHIS^VAFCPDT2 ;CMOR History removed, called changed to EXT^VAFCPDT2 **837, MVI_918 "RTN","VAFCPDAT",196,0) D EXT^VAFCPDT2 "RTN","VAFCPDAT",197,0) DONE ; "RTN","VAFCPDAT",198,0) I QFLG G QUIT "RTN","VAFCPDAT",199,0) I ($E(IOST,1,2)="C-") S LNQ=24 D SS "RTN","VAFCPDAT",200,0) ; "RTN","VAFCPDAT",201,0) QUIT ; "RTN","VAFCPDAT",202,0) K %,CMOR,DIC,DIR,DIRUT,DNODE,GOT,HDT,HFULLICN,HIS,HISCHK,HISDT,HISICN,JJ,LIEN "RTN","VAFCPDAT",203,0) K LINST,LN,LSTDT,MNODE,REACODE,REASON,SCN,SCORE,SITE,SITEIEN,SITENAM,SITENUM "RTN","VAFCPDAT",204,0) K SS,SUBN,SUBARR,TERM,TERMDT,TF,TFARR,TFDATA,TFIEN,TFNM,Y,D,CHG,CHGNODE "RTN","VAFCPDAT",205,0) K HISNODE,DIFF,INST,RGDFN,SCRDT,STATION,STA,LN2,NAME,LSTSORT,LNQ,QFLG,MBI "RTN","VAFCPDAT",206,0) Q "RTN","VAFCPDAT",207,0) TFHDR ; "RTN","VAFCPDAT",208,0) W !!,"Treating Facilities:",?22,"Station:",?32,"DT Last Treated",?54,"Event Reason" "RTN","VAFCPDAT",209,0) W !,"--------------------",?22,"--------",?32,"---------------",?54,"------------" "RTN","VAFCPDAT",210,0) Q "RTN","VAFCPDAT",211,0) ICNHDR W !!,"ICN History:",!,"------------" "RTN","VAFCPDAT",212,0) Q "RTN","VAFCPDAT",213,0) ; "RTN","VAFCPDAT",214,0) SS S DIR(0)="E" D D ^DIR K DIR I 'Y S QFLG=1 "RTN","VAFCPDAT",215,0) .S SS=LNQ-$Y F JJ=1:1:SS W ! "RTN","VAFCPDAT",216,0) Q "RTN","VAFCPTED") 0^7^B87903386^B71161644 "RTN","VAFCPTED",1,0) VAFCPTED ;ISA/RJS,Zoltan-EDIT EXISTING PATIENT ;4/15/22 16:30 "RTN","VAFCPTED",2,0) ;;5.3;Registration;**149,333,756,837,974,1059,1071**;Aug 13, 1993;Build 4 "RTN","VAFCPTED",3,0) ; "RTN","VAFCPTED",4,0) EDIT(DGDFN,ARRAY,STRNGDR) ;-- Edits existing patient "RTN","VAFCPTED",5,0) ;Input: "RTN","VAFCPTED",6,0) ; DGDFN - IEN in the PATIENT (#2) file "RTN","VAFCPTED",7,0) ; ARRAY - Array containing fields to be edited. "RTN","VAFCPTED",8,0) ; Ex. ARRAY(.111)="123 STREET" or ARRAY(2,.111)="123... "RTN","VAFCPTED",9,0) ; STRNGDR - String of delimited PATIENT (#2) file fields in the order "RTN","VAFCPTED",10,0) ; in which the fields will be processed by DIE. "RTN","VAFCPTED",11,0) ; Ex. ".01;.03;.05..." "RTN","VAFCPTED",12,0) ;Output: "RTN","VAFCPTED",13,0) ; No output "RTN","VAFCPTED",14,0) ; "RTN","VAFCPTED",15,0) S U="^" "RTN","VAFCPTED",16,0) N LOCKFLE,FLD,ZTQUEUED,DIQUIET,VAFCX,STRNG "RTN","VAFCPTED",17,0) S (ZTQUEUED,DIQUIET)=1 "RTN","VAFCPTED",18,0) L +^DPT(DGDFN):60 "RTN","VAFCPTED",19,0) S LOCKFLE=$T ; Need to remember whether the lock went through. "RTN","VAFCPTED",20,0) ;process the given PATIENT file DR string in the given order "RTN","VAFCPTED",21,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",22,0) ; "RTN","VAFCPTED",23,0) ;Do Address Bulletin if incoming Address does not equal existing "RTN","VAFCPTED",24,0) ;Address - removed bulletin with patch DG*5.3*333 "RTN","VAFCPTED",25,0) ;I $D(@ARRAY@(.111))!$D(@ARRAY@(.112))!$D(@ARRAY@(.113))!$D(@ARRAY@(.114))!$D(@ARRAY@(.115))!$D(@ARRAY@(.117))!$D(@ARRAY@(.1112)) D "RTN","VAFCPTED",26,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",27,0) ; "RTN","VAFCPTED",28,0) I LOCKFLE L -^DPT(DGDFN) "RTN","VAFCPTED",29,0) ; "RTN","VAFCPTED",30,0) K DIE,DA "RTN","VAFCPTED",31,0) Q "RTN","VAFCPTED",32,0) ; "RTN","VAFCPTED",33,0) LOAD ; -- Loads fields to patient file "RTN","VAFCPTED",34,0) N DR,DIE "RTN","VAFCPTED",35,0) ;**756 check if updating ALIAS "RTN","VAFCPTED",36,0) I FLD=1 D Q "RTN","VAFCPTED",37,0) . ;**974,Story 841921 (mko): If flag is not set, compare and update the Alias .01; "RTN","VAFCPTED",38,0) . ; If the flag is set, compare and update the Alias Name Components "RTN","VAFCPTED",39,0) . I '$$GETFLAG D ALIAS Q "RTN","VAFCPTED",40,0) . D ALIASNC(ARRAY,DGDFN,.RGER) "RTN","VAFCPTED",41,0) ;**974,Story 841921 (mko): File name components "RTN","VAFCPTED",42,0) I FLD=1.01 D Q "RTN","VAFCPTED",43,0) . N NAME "RTN","VAFCPTED",44,0) . M NAME=@ARRAY@(1.01) "RTN","VAFCPTED",45,0) . D UPDNC(DGDFN,.NAME) "RTN","VAFCPTED",46,0) I FLD=.025 D UPDSEXOR(ARRAY,DGDFN,.RGER) Q ;**1059, VAMPI-11114 (dri) file sexual orientation "RTN","VAFCPTED",47,0) I FLD=.2406 D UPDPRON(ARRAY,DGDFN,.RGER) Q ;**1059, VAMPI-11118 (dri) file pronoun "RTN","VAFCPTED",48,0) S DA=DGDFN,DIE="^DPT(" "RTN","VAFCPTED",49,0) I $G(@ARRAY@(FLD))="" Q "RTN","VAFCPTED",50,0) I $G(@ARRAY@(FLD))["@" S @ARRAY@(FLD)="@" "RTN","VAFCPTED",51,0) I $G(@ARRAY@(FLD))[U Q "RTN","VAFCPTED",52,0) S DR=FLD_"///^S X=$G(@ARRAY@(FLD))" "RTN","VAFCPTED",53,0) D ^DIE "RTN","VAFCPTED",54,0) Q "RTN","VAFCPTED",55,0) ; "RTN","VAFCPTED",56,0) UPDNC(DGDFN,NAME) ; "RTN","VAFCPTED",57,0) N FDA,IEN,MSG,DIERR "RTN","VAFCPTED",58,0) ;Call updater to add or edit entry in Name Component file "RTN","VAFCPTED",59,0) S FDA(20,"?+1,",.01)=2 "RTN","VAFCPTED",60,0) S FDA(20,"?+1,",.02)=.01 "RTN","VAFCPTED",61,0) S FDA(20,"?+1,",.03)=DGDFN_"," "RTN","VAFCPTED",62,0) S:$D(NAME("FAMILY"))#2 FDA(20,"?+1,",1)=NAME("FAMILY") "RTN","VAFCPTED",63,0) S:$D(NAME("GIVEN"))#2 FDA(20,"?+1,",2)=NAME("GIVEN") "RTN","VAFCPTED",64,0) S:$D(NAME("MIDDLE"))#2 FDA(20,"?+1,",3)=NAME("MIDDLE") "RTN","VAFCPTED",65,0) S:$D(NAME("SUFFIX"))#2 FDA(20,"?+1,",5)=NAME("SUFFIX") "RTN","VAFCPTED",66,0) D UPDATE^DIE("K","FDA","IEN","MSG") "RTN","VAFCPTED",67,0) Q "RTN","VAFCPTED",68,0) ; "RTN","VAFCPTED",69,0) ALIAS ;update Alias multiple **756 "RTN","VAFCPTED",70,0) ;allow the synchronizing of the Alias multiple with the data passed in the array "RTN","VAFCPTED",71,0) ;array(1,x)=name (last, first middle suffix format)^ssn "RTN","VAFCPTED",72,0) N HAVE,I,MIEN,ADD,DONE,FDA,MPIFERR,DEL,ALIAS,CNT,DGALIAS "RTN","VAFCPTED",73,0) M HAVE=^DPT(DGDFN,.01) "RTN","VAFCPTED",74,0) S CNT=0 "RTN","VAFCPTED",75,0) ;see if any need to be added "RTN","VAFCPTED",76,0) S I=0 F S I=$O(@ARRAY@(1,I)) Q:'I D ;loop through incoming data "RTN","VAFCPTED",77,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",78,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",79,0) .I ADD S ALIAS=@ARRAY@(1,I) D ;add new entry to subfile "RTN","VAFCPTED",80,0) ..S FDA(2.01,"+"_I_","_DGDFN_",",.01)=$P(@ARRAY@(1,I),"^") "RTN","VAFCPTED",81,0) ..S FDA(2.01,"+"_I_","_DGDFN_",",1)=$P(@ARRAY@(1,I),"^",2) "RTN","VAFCPTED",82,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",83,0) ;delete entries "RTN","VAFCPTED",84,0) K FDA,MPIFERR "RTN","VAFCPTED",85,0) S MIEN=0 F S MIEN=$O(HAVE(MIEN)) Q:'MIEN D ;loop through existing data "RTN","VAFCPTED",86,0) . ; **837,MVI_805 check for duplicates (name + ssn combination) "RTN","VAFCPTED",87,0) . S HAVE=$P($G(HAVE(MIEN,0)),"^",1,2) "RTN","VAFCPTED",88,0) . X $S(HAVE="":"",$D(DGALIAS(HAVE)):"S FDA(2.01,MIEN_"",""_DGDFN_"","",.01)=""@"" Q",1:"S DGALIAS(HAVE)=HAVE") "RTN","VAFCPTED",89,0) . ; "RTN","VAFCPTED",90,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",91,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",92,0) . I DEL S FDA(2.01,MIEN_","_DGDFN_",",.01)="@" ;existing entry to delete "RTN","VAFCPTED",93,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",94,0) Q "RTN","VAFCPTED",95,0) ; "RTN","VAFCPTED",96,0) ALIASNC(ARRAY,DGDFN,RGER) ;Compare incoming Alias Name Components with existing Alias Name Components and add or delete as necessary "RTN","VAFCPTED",97,0) ;**974,Story 841921 (mko): New subroutine "RTN","VAFCPTED",98,0) N FDA,HAVE,IEN,IENROOT,IN,NC,NCIEN,NCIENS,ORIG,SEQ,SUB "RTN","VAFCPTED",99,0) ; "RTN","VAFCPTED",100,0) ;Create IN("surname^firstname^middlename^suffix^ssn",seq#)="" from incoming data "RTN","VAFCPTED",101,0) S SEQ=0 F S SEQ=$O(@ARRAY@(1,SEQ)) Q:'SEQ D "RTN","VAFCPTED",102,0) . S IN(@ARRAY@(1,SEQ,"NC")_"^"_$P(@ARRAY@(1,SEQ),"^",2),SEQ)="" "RTN","VAFCPTED",103,0) ; "RTN","VAFCPTED",104,0) ;Create ORIG("surname^firstname^middlename^suffix^ssn",subien)="" from existing data "RTN","VAFCPTED",105,0) M HAVE=^DPT(DGDFN,.01) "RTN","VAFCPTED",106,0) S IEN=0 F S IEN=$O(HAVE(IEN)) Q:'IEN D "RTN","VAFCPTED",107,0) . S NCIEN=$P(HAVE(IEN,0),"^",3) "RTN","VAFCPTED",108,0) . D:$P(HAVE(IEN,0),"^",3)>0 "RTN","VAFCPTED",109,0) .. S NC=$G(^VA(20,NCIEN,1)) "RTN","VAFCPTED",110,0) .. S SUB=$P(NC,"^",1,3)_"^"_$P(NC,"^",5)_"^"_$P(HAVE(IEN,0),"^",2) "RTN","VAFCPTED",111,0) .. ;If this is a duplicate, set the FDA for deletion here "RTN","VAFCPTED",112,0) .. S:$D(ORIG(SUB)) FDA(2.01,IEN_","_DGDFN_",",.01)="@" "RTN","VAFCPTED",113,0) .. S ORIG(SUB,IEN)="" "RTN","VAFCPTED",114,0) ; "RTN","VAFCPTED",115,0) ;Loop through ORIG to delete Aliases that aren't in IN array "RTN","VAFCPTED",116,0) S SUB="" F S SUB=$O(ORIG(SUB)) Q:SUB="" D "RTN","VAFCPTED",117,0) . D:'$D(IN(SUB)) "RTN","VAFCPTED",118,0) .. S IEN=$O(ORIG(SUB,0)) Q:'IEN "RTN","VAFCPTED",119,0) .. S FDA(2.01,IEN_","_DGDFN_",",.01)="@" "RTN","VAFCPTED",120,0) D:$D(FDA) "RTN","VAFCPTED",121,0) . D FILE^DIE("E","FDA","MSG") K FDA "RTN","VAFCPTED",122,0) . I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG "RTN","VAFCPTED",123,0) ; "RTN","VAFCPTED",124,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",125,0) S SUB="" F S SUB=$O(IN(SUB)) Q:SUB="" D "RTN","VAFCPTED",126,0) . D:'$D(ORIG(SUB)) "RTN","VAFCPTED",127,0) .. S SEQ=$O(IN(SUB,0)) "RTN","VAFCPTED",128,0) .. S FDA(2.01,"+"_SEQ_","_DGDFN_",",.01)=$$FMTNAME(@ARRAY@(1,SEQ,"NC")) "RTN","VAFCPTED",129,0) .. S FDA(2.01,"+"_SEQ_","_DGDFN_",",1)=$P(@ARRAY@(1,SEQ),"^",2) "RTN","VAFCPTED",130,0) D:$D(FDA) "RTN","VAFCPTED",131,0) . ;Add the Alias and Alias SSN "RTN","VAFCPTED",132,0) . D UPDATE^DIE("E","FDA","IENROOT","MSG") K FDA "RTN","VAFCPTED",133,0) . I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG "RTN","VAFCPTED",134,0) . ;For each Alias added, update the corresponding Name Components entry "RTN","VAFCPTED",135,0) . S SEQ=0 F S SEQ=$O(IENROOT(SEQ)) Q:'SEQ D "RTN","VAFCPTED",136,0) .. S IEN=$G(IENROOT(SEQ)) Q:IEN'>0 "RTN","VAFCPTED",137,0) .. S NCIENS=$P($G(^DPT(DGDFN,.01,IEN,0)),"^",3)_"," Q:'NCIENS "RTN","VAFCPTED",138,0) .. S NC=$G(@ARRAY@(1,SEQ,"NC")) "RTN","VAFCPTED",139,0) .. S FDA(20,NCIENS,1)=$P(NC,"^") "RTN","VAFCPTED",140,0) .. S FDA(20,NCIENS,2)=$P(NC,"^",2) "RTN","VAFCPTED",141,0) .. S FDA(20,NCIENS,3)=$P(NC,"^",3) "RTN","VAFCPTED",142,0) .. S FDA(20,NCIENS,5)=$P(NC,"^",4) "RTN","VAFCPTED",143,0) .. D FILE^DIE("E","FDA","MSG") K FDA "RTN","VAFCPTED",144,0) .. I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG "RTN","VAFCPTED",145,0) Q "RTN","VAFCPTED",146,0) ; "RTN","VAFCPTED",147,0) BLDERR(MSGROOT) ;Build an error from the error message array "RTN","VAFCPTED",148,0) ;**974,Story 841921 (mko): New subroutine "RTN","VAFCPTED",149,0) N ERRARR,ERRMSG,I "RTN","VAFCPTED",150,0) D MSG^DIALOG("AE",.ERRARR,"","",MSGROOT) "RTN","VAFCPTED",151,0) S ERRMSG="",I=0 F S I=$O(ERRARR(I)) Q:'I S ERRMSG=ERRMSG_$S(ERRMSG]"":" ",1:"")_$G(ERRARR(I)) "RTN","VAFCPTED",152,0) Q ERRMSG "RTN","VAFCPTED",153,0) ; "RTN","VAFCPTED",154,0) FMTNAME(ARRAY,LEN) ;Return a formatted name from cleaned Name Components that doesn't exceed LEN characters in length. "RTN","VAFCPTED",155,0) ;**974,Story 841921 (mko): New function (duplicate of FMTNAME^RGADTP3) "RTN","VAFCPTED",156,0) N NC "RTN","VAFCPTED",157,0) S:'$G(LEN) LEN=30 "RTN","VAFCPTED",158,0) ; "RTN","VAFCPTED",159,0) ;If ARRAY is passed as a string and doesn't have descendants assume it equals "surname^first^middle^suffix" "RTN","VAFCPTED",160,0) D:$D(ARRAY)=1 "RTN","VAFCPTED",161,0) . S ARRAY("SURNAME")=$P(ARRAY,"^") "RTN","VAFCPTED",162,0) . S ARRAY("FIRST")=$P(ARRAY,"^",2) "RTN","VAFCPTED",163,0) . S ARRAY("MIDDLE")=$P(ARRAY,"^",3) "RTN","VAFCPTED",164,0) . S ARRAY("SUFFIX")=$P(ARRAY,"^",4) "RTN","VAFCPTED",165,0) ; "RTN","VAFCPTED",166,0) ;Clean the components "RTN","VAFCPTED",167,0) S NC("FAMILY")=$$CLEANC^XLFNAME($G(ARRAY("SURNAME"))) "RTN","VAFCPTED",168,0) S NC("GIVEN")=$$CLEANC^XLFNAME($G(ARRAY("FIRST"))) "RTN","VAFCPTED",169,0) S NC("MIDDLE")=$$CLEANC^XLFNAME($G(ARRAY("MIDDLE"))) "RTN","VAFCPTED",170,0) S NC("SUFFIX")=$$CLEANC^XLFNAME($G(ARRAY("SUFFIX"))) "RTN","VAFCPTED",171,0) ; "RTN","VAFCPTED",172,0) ;Build a full name, maximum length LEN "RTN","VAFCPTED",173,0) Q $$NAMEFMT^XLFNAME(.NC,"F","CL"_LEN) "RTN","VAFCPTED",174,0) ; "RTN","VAFCPTED",175,0) GETFLAG() ;Get the value of the name components flag "RTN","VAFCPTED",176,0) ;**974,Story 841921 (mko): New function "RTN","VAFCPTED",177,0) I $T(GETFLAG^MPIFNAMC)]"" Q $$GETFLAG^MPIFNAMC "RTN","VAFCPTED",178,0) Q 0 "RTN","VAFCPTED",179,0) ; "RTN","VAFCPTED",180,0) UPDSEXOR(ARRAY,DGDFN,RGER) ;**1059, VAMPI-11114 (dri) compare incoming sexual orientation multiple with existing and add/update "RTN","VAFCPTED",181,0) ;**1071 VAMPI-13755 (dri) - include status, date created, date last updated to compare and file "RTN","VAFCPTED",182,0) ; Input: "RTN","VAFCPTED",183,0) ; ARRAY = ARAY(2) "RTN","VAFCPTED",184,0) ; ARAY(2,.025,n) = sexual orientation code ^ status ^ date created ^ date last update "RTN","VAFCPTED",185,0) ; DGDFN = patient's dfn "RTN","VAFCPTED",186,0) ; "RTN","VAFCPTED",187,0) ; Example: "RTN","VAFCPTED",188,0) ; ARAY(2,.025,1)="CND^I^3220128^3220128" "RTN","VAFCPTED",189,0) ; ARAY(2,.025,2)="DTK^E^3220128^3220128" "RTN","VAFCPTED",190,0) ; ARAY(2,.025,3)="OTH^A^3220128^3220128" "RTN","VAFCPTED",191,0) ; "RTN","VAFCPTED",192,0) N CUR,FDA,I,INC,SOCODE,SOIEN,VAFCERR "RTN","VAFCPTED",193,0) I $G(@ARRAY@(.025,1))["@" S @ARRAY@(.025,1)="@" ;change "@" to @, since no so's received in obx's delete all so's at the vista "RTN","VAFCPTED",194,0) I $G(@ARRAY@(.025,1))'="@" S I=0 F S I=$O(@ARRAY@(.025,I)) Q:'I S SOCODE=$P($G(@ARRAY@(.025,I)),"^",1) I SOCODE'="",(SOCODE'["@"),(SOCODE'="""""") S INC(SOCODE)=I ;incoming so's "RTN","VAFCPTED",195,0) S I=0 F S I=$O(^DPT(DGDFN,.025,I)) Q:'I S SOIEN=+$P($G(^(I,0)),"^",1),SOCODE=$P($G(^DG(47.77,SOIEN,0)),"^",2) I SOCODE'="" S CUR(SOCODE)=I ;current so's at vista "RTN","VAFCPTED",196,0) ; "RTN","VAFCPTED",197,0) ;loop through incoming sexual orientations and add/update "RTN","VAFCPTED",198,0) S SOCODE="" F S SOCODE=$O(INC(SOCODE)) Q:SOCODE="" D "RTN","VAFCPTED",199,0) .I '$D(CUR(SOCODE)) D Q ;an add to vista "RTN","VAFCPTED",200,0) ..F I=1:1:4 S FDA(2.025,"+"_INC(SOCODE)_","_DGDFN_",",I*.01)=$P($G(@ARRAY@(.025,INC(SOCODE))),"^",I) "RTN","VAFCPTED",201,0) ..S FDA(2.025,"+"_INC(SOCODE)_","_DGDFN_",",.06)="R" ;since this entry is new to vista and via hl7 it came from somewhere else, type of update is 'R'emote "RTN","VAFCPTED",202,0) .; "RTN","VAFCPTED",203,0) .I $D(CUR(SOCODE)) D ;an update to vista if something changed "RTN","VAFCPTED",204,0) ..F I=2:1:4 I $P($G(@ARRAY@(.025,INC(SOCODE))),"^",I)'=$P($G(^DPT(DGDFN,.025,CUR(SOCODE),0)),"^",I) D "RTN","VAFCPTED",205,0) ...S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",I*.01)=$P($G(@ARRAY@(.025,INC(SOCODE))),"^",I) "RTN","VAFCPTED",206,0) ...;S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",.05)="@" "RTN","VAFCPTED",207,0) ...S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",.06)="R" ;since this entry is being modified via hl7 it came from somewhere else, note is deleted and type of update is 'R'emote "RTN","VAFCPTED",208,0) ; "RTN","VAFCPTED",209,0) ;loop through vista and delete if not in incoming so's "RTN","VAFCPTED",210,0) S SOCODE="" F S SOCODE=$O(CUR(SOCODE)) Q:SOCODE="" I '$D(INC(SOCODE)) S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",.01)="@" "RTN","VAFCPTED",211,0) ; "RTN","VAFCPTED",212,0) I $D(FDA) D UPDATE^DIE("E","FDA",,"VAFCERR") I $G(VAFCERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_VAFCERR("DIERR",1,"TEXT",1) "RTN","VAFCPTED",213,0) Q "RTN","VAFCPTED",214,0) ; "RTN","VAFCPTED",215,0) UPDPRON(ARRAY,DGDFN,RGER) ;**1059, VAMPI-11118 (dri) compare incoming pronoun multiple with existing and add/update "RTN","VAFCPTED",216,0) ; Input: "RTN","VAFCPTED",217,0) ; ARRAY = ARAY(2) "RTN","VAFCPTED",218,0) ; ARAY(2,.2406,n) = pronoun code "RTN","VAFCPTED",219,0) ; DGDFN = patient's dfn "RTN","VAFCPTED",220,0) ; "RTN","VAFCPTED",221,0) ; Example: "RTN","VAFCPTED",222,0) ; ARAY(2,.2406,1)="OTH" "RTN","VAFCPTED",223,0) ; ARAY(2,.2406,2)="PTN" "RTN","VAFCPTED",224,0) ; "RTN","VAFCPTED",225,0) N CUR,FDA,I,INC,PRCODE,PRIEN,VAFCERR "RTN","VAFCPTED",226,0) I $G(@ARRAY@(.2406,1))["@" S @ARRAY@(.2406,1)="@" ;change "@" to @, since no pronouns received in obx's delete all pronouns at the vista "RTN","VAFCPTED",227,0) I $G(@ARRAY@(.2406,1))'="@" S I=0 F S I=$O(@ARRAY@(.2406,I)) Q:'I S PRCODE=$P($G(@ARRAY@(.2406,I)),"^",1) I PRCODE'="",(PRCODE'["@"),(PRCODE'="""""") S INC(PRCODE)=I ;incoming pronouns "RTN","VAFCPTED",228,0) S I=0 F S I=$O(^DPT(DGDFN,.2406,I)) Q:'I S PRIEN=+$P($G(^(I,0)),"^",1),PRCODE=$P($G(^DG(47.78,PRIEN,0)),"^",2) I PRCODE'="" S CUR(PRCODE)=I ;current pronouns at vista "RTN","VAFCPTED",229,0) ; "RTN","VAFCPTED",230,0) ;loop through incoming pronoun's and add if not in vista "RTN","VAFCPTED",231,0) S PRCODE="" F S PRCODE=$O(INC(PRCODE)) Q:PRCODE="" I '$D(CUR(PRCODE)) S FDA(2.2406,"+"_INC(PRCODE)_","_DGDFN_",",.01)=PRCODE "RTN","VAFCPTED",232,0) ; "RTN","VAFCPTED",233,0) ;loop through vista and delete if not in incoming pronouns "RTN","VAFCPTED",234,0) S PRCODE="" F S PRCODE=$O(CUR(PRCODE)) Q:PRCODE="" I '$D(INC(PRCODE)) S FDA(2.2406,CUR(PRCODE)_","_DGDFN_",",.01)="@" "RTN","VAFCPTED",235,0) ; "RTN","VAFCPTED",236,0) I $D(FDA) D UPDATE^DIE("E","FDA",,"VAFCERR") I $G(VAFCERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_VAFCERR("DIERR",1,"TEXT",1) "RTN","VAFCPTED",237,0) Q "RTN","VAFCPTED",238,0) ; "RTN","VAFCSB") 0^6^B81393667^B75363862 "RTN","VAFCSB",1,0) VAFCSB ;BIR/CMC-CONT ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;2/2/22 17:24 "RTN","VAFCSB",2,0) ;;5.3;Registration;**707,756,825,876,902,926,967,1059,1071**;Aug 13, 1993;Build 4 "RTN","VAFCSB",3,0) ; "RTN","VAFCSB",4,0) ;Reference to $$XAMDT^RAO7UTL1 is supported by IA #4875 "RTN","VAFCSB",5,0) ;Reference to RESUTLS^LRPXAPI is supported by IA #4245 "RTN","VAFCSB",6,0) ;Reference to PROF^PSO52API is supported by IA #4820 "RTN","VAFCSB",7,0) ; "RTN","VAFCSB",8,0) PV2() ;build pv2 segment "RTN","VAFCSB",9,0) N PV2,LSTA,APPT,VASD,VAIP,VARP,VAROOT "RTN","VAFCSB",10,0) S PV2="" "RTN","VAFCSB",11,0) ;get next outpatient appointment "RTN","VAFCSB",12,0) K ^UTILITY("VASD",$J) S VASD("F")=DT D SDA^VADPT "RTN","VAFCSB",13,0) S APPT=$P($G(^UTILITY("VASD",$J,1,"I")),"^") "RTN","VAFCSB",14,0) I APPT'="" S $P(PV2,HL("FS"),9)=$$HLDATE^HLFNC(APPT) "RTN","VAFCSB",15,0) ;GET LAST ADMISSION DATE "RTN","VAFCSB",16,0) K VAIP S VAIP("D")="LAST",VAIP("M")=0 D IN5^VADPT "RTN","VAFCSB",17,0) ; **825,CR_1184: for PV2-14, it will be re-set as the 15th piece "RTN","VAFCSB",18,0) ; in PV2 segment a few lines below "RTN","VAFCSB",19,0) ; I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),15)=$$HLDATE^HLFNC($P(VAIP(3),"^")) "RTN","VAFCSB",20,0) I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),14)=$$HLDATE^HLFNC($P(VAIP(3),"^")) "RTN","VAFCSB",21,0) ;get last registration "RTN","VAFCSB",22,0) S VAROOT="VARP" "RTN","VAFCSB",23,0) D REG^VADPT "RTN","VAFCSB",24,0) I $D(VARP(1,"I")),$G(VARP(1,"I"))>0 S $P(PV2,HL("FS"),46)=$$HLDATE^HLFNC($P(VARP(1,"I"),"^"),"DT"),$P(PV2,HL("FS"),24)="CR" "RTN","VAFCSB",25,0) ;**756 ^ ONLY RETURN DATE FOR LAST REGISTRATION AS HL7 STANDARD CAN ONLY HAVE DATE "RTN","VAFCSB",26,0) I PV2'="" S PV2="PV2"_HL("FS")_PV2 "RTN","VAFCSB",27,0) Q PV2 "RTN","VAFCSB",28,0) ; "RTN","VAFCSB",29,0) PHARA() ;build obx to show active prescriptions "RTN","VAFCSB",30,0) N RET S RET="" "RTN","VAFCSB",31,0) I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET "RTN","VAFCSB",32,0) N PHARM,DGLIST "RTN","VAFCSB",33,0) S PHARM="" D PROF^PSO52API(DFN,"DGLIST") "RTN","VAFCSB",34,0) I +$G(^TMP($J,"DGLIST",DFN,0))>0 S PHARM="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"ACTIVE PRESCRIPTIONS"_HL("FS")_HL("FS")_"Y" "RTN","VAFCSB",35,0) ;**756 CE added as the data type "RTN","VAFCSB",36,0) Q PHARM "RTN","VAFCSB",37,0) ; "RTN","VAFCSB",38,0) SIG(DFN) ;**876 MVI_3467 (ckn) Build OBX for Self Identified Gender "RTN","VAFCSB",39,0) N SIG,SIGE,SIGTMP,OBX S OBX="" "RTN","VAFCSB",40,0) ;I '$$PATCH^XPDUTL("DG*5.3*876") Q OBX "RTN","VAFCSB",41,0) S DIC=2,DA=DFN,DR=".024",DIQ="SIGTMP",DIQ(0)="I,E,N" D EN^DIQ1 "RTN","VAFCSB",42,0) I '$D(SIGTMP) K DA,DR,DIQ Q OBX "RTN","VAFCSB",43,0) S SIG=$G(SIGTMP(2,DFN,DR,"I")),SIGE=$G(SIGTMP(2,DFN,DR,"E")) "RTN","VAFCSB",44,0) S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SELF ID GENDER"_HL("FS")_HL("FS")_SIG_$E(HL("ECH"),1)_SIGE "RTN","VAFCSB",45,0) K DA,DR,DIC,DIQ "RTN","VAFCSB",46,0) Q OBX "RTN","VAFCSB",47,0) ; "RTN","VAFCSB",48,0) DODF(DFN) ;**902 MVI_4898 (ckn) Build OBX for DOD fields "RTN","VAFCSB",49,0) N DODTMP,DODEB,DODLEB,DODSRC,DODLUPD,DODSRCI,DODSRCE,CS,DODLNAM "RTN","VAFCSB",50,0) N DODFNAM,DODMNAM,DODEBE,DODEBI,DODLEBE,DODLEBI,DODSRCCD "RTN","VAFCSB",51,0) S CS=$E(HL("ECH")),SC=$E(HL("ECH"),4) "RTN","VAFCSB",52,0) S DIC=2,DA=DFN,DR=".352;.353;.354;.355",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1 "RTN","VAFCSB",53,0) S DODSRCI=$G(DODTMP(2,DFN,.353,"I")),DODSRCE=$G(DODTMP(2,DFN,.353,"E")),DODSRC=HL("Q") "RTN","VAFCSB",54,0) ; **926, Story #323009 (ckn): Source of Notification moved from set of codes to pointer which is pointing to new Source Of Notification file (#47.76) "RTN","VAFCSB",55,0) I DODSRCE'="" D "RTN","VAFCSB",56,0) . S DODSRCCD=$P($G(^DG(47.76,DODSRCI,0)),"^",2) "RTN","VAFCSB",57,0) . S DODSRC=DODSRCCD_CS_DODSRCE_CS_"L" "RTN","VAFCSB",58,0) I DODSRCE'="" S DODSRC=DODSRCI_CS_DODSRCE_CS_"L" "RTN","VAFCSB",59,0) S DODLUPD=$G(DODTMP(2,DFN,.354,"I")) S DODLUPD=$S(DODLUPD="":HL("Q"),1:$$HLDATE^HLFNC(DODLUPD)) "RTN","VAFCSB",60,0) ;If LAST EDITED BY field(#.355) have value, use it to populate sequence 16 of OBX "RTN","VAFCSB",61,0) ;If LAST EDITED BY field(#.355) does not have value, use DEATH ENTERED BY field(#.352) to populate sequence 16 of OBX "RTN","VAFCSB",62,0) ;If both fields empty, send double quotes in sequence 16 of OBX "RTN","VAFCSB",63,0) S DODLEB=HL("Q") ;Default seq 16 "RTN","VAFCSB",64,0) S DODEBE=$G(DODTMP(2,DFN,.352,"E")),DODEBI=$G(DODTMP(2,DFN,.352,"I")) ;DOD Entered by "RTN","VAFCSB",65,0) S DODLEBE=$G(DODTMP(2,DFN,.355,"E")),DODLEBI=$G(DODTMP(2,DFN,.355,"I")) ;DOD Last Edited By "RTN","VAFCSB",66,0) I DODLEBE'="" D "RTN","VAFCSB",67,0) .S DODLEBE=$$HLNAME^HLFNC(DODLEBE,CS),DODLNAM=$S($P(DODLEBE,CS)="":HL("Q"),1:$P(DODLEBE,CS)),DODFNAM=$S($P(DODLEBE,CS,2)="":HL("Q"),1:$P(DODLEBE,CS,2)),DODMNAM=$S($P(DODLEBE,CS,3)="":HL("Q"),1:$P(DODLEBE,CS,3)) "RTN","VAFCSB",68,0) .S DODLEB=$S(DODLEBI="":HL("Q"),1:DODLEBI)_CS_DODLNAM_CS_DODFNAM_CS_DODMNAM_CS_CS_CS_CS_CS_"USVHA"_SC_SC_"0363"_CS_"L"_CS_CS_CS_"PN"_CS_"VA FACILITY ID"_SC_$P($$SITE^VASITE(),"^",3)_SC_"L" "RTN","VAFCSB",69,0) I DODLEBE="",(DODEBE'="") D "RTN","VAFCSB",70,0) .S DODEBE=$$HLNAME^HLFNC(DODEBE,CS),DODLNAM=$S($P(DODEBE,CS)="":HL("Q"),1:$P(DODEBE,CS)),DODFNAM=$S($P(DODEBE,CS,2)="":HL("Q"),1:$P(DODEBE,CS,2)),DODMNAM=$S($P(DODEBE,CS,3)="":HL("Q"),1:$P(DODEBE,CS,3)) "RTN","VAFCSB",71,0) .S DODLEB=$S(DODEBI="":HL("Q"),1:DODEBI)_CS_DODLNAM_CS_DODFNAM_CS_DODMNAM_CS_CS_CS_CS_CS_"USVHA"_SC_SC_"0363"_CS_"L"_CS_CS_CS_"PN"_CS_"VA FACILITY ID"_SC_$P($$SITE^VASITE(),"^",3)_SC_"L" "RTN","VAFCSB",72,0) S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DATA"_HL("FS")_HL("FS")_DODSRC_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"R"_HL("FS")_HL("FS")_HL("FS")_DODLUPD_HL("FS")_HL("FS")_$G(DODLEB) "RTN","VAFCSB",73,0) K DA,DR,DIC,DIQ "RTN","VAFCSB",74,0) Q OBX "RTN","VAFCSB",75,0) ; "RTN","VAFCSB",76,0) DODD(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DOCUMENTS "RTN","VAFCSB",77,0) N OBX,DODTMP,DODDI,DODD,DODDE,DODDCD "RTN","VAFCSB",78,0) S CS=$E(HL("ECH")) "RTN","VAFCSB",79,0) S DIC=2,DA=DFN,DR=".357",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1 "RTN","VAFCSB",80,0) S DODDI=$G(DODTMP(2,DFN,.357,"I")),DODDE=$G(DODTMP(2,DFN,.357,"E")),DODD=HL("Q") "RTN","VAFCSB",81,0) I DODDE'="" D "RTN","VAFCSB",82,0) . S DODDCD=$P($G(^DG(47.75,DODDI,0)),"^",2) "RTN","VAFCSB",83,0) . S DODD=DODDCD_CS_DODDE_CS_"L" "RTN","VAFCSB",84,0) S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DOCUMENTS"_HL("FS")_HL("FS")_DODD "RTN","VAFCSB",85,0) K DA,DR,DIC,DIQ "RTN","VAFCSB",86,0) Q OBX "RTN","VAFCSB",87,0) ; "RTN","VAFCSB",88,0) DODOPT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH OPTION "RTN","VAFCSB",89,0) N OBX,DODOPT,DODOPTE,DODOPTI "RTN","VAFCSB",90,0) S CS=$E(HL("ECH")) "RTN","VAFCSB",91,0) S DIC=2,DA=DFN,DR=".358",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1 "RTN","VAFCSB",92,0) S DODOPTE=$G(DODTMP(2,DFN,.358,"E")),DODOPTI=$G(DODTMP(2,DFN,.358,"I")),DODOPT=HL("Q") "RTN","VAFCSB",93,0) I DODOPTE'="" S DODOPT=DODOPTI_CS_DODOPTE_CS_"L" "RTN","VAFCSB",94,0) S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH OPTION"_HL("FS")_HL("FS")_DODOPT "RTN","VAFCSB",95,0) K DA,DR,DIC,DIQ "RTN","VAFCSB",96,0) Q OBX "RTN","VAFCSB",97,0) ; "RTN","VAFCSB",98,0) DODDISDT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DISCHARGE DATE "RTN","VAFCSB",99,0) ;Q OBX "RTN","VAFCSB",100,0) ; "RTN","VAFCSB",101,0) DODNTPRV(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH NOTIFICATION "RTN","VAFCSB",102,0) N OBX,DODNP,STN "RTN","VAFCSB",103,0) S CS=$E(HL("ECH")),STN=$$SITE^VASITE(),DODNP="" "RTN","VAFCSB",104,0) ;Populate notify provider if Date of Death last updated have value "RTN","VAFCSB",105,0) I $$GET1^DIQ(2,DFN_",",.354,"I")'="" S DODNP=$P(STN,"^",3)_CS_$P(STN,"^",2)_CS_"L" "RTN","VAFCSB",106,0) S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"NOTIFY PROVIDER"_HL("FS")_HL("FS")_DODNP "RTN","VAFCSB",107,0) Q OBX "RTN","VAFCSB",108,0) ; "RTN","VAFCSB",109,0) SECLOG(DFN) ;**1059, Story #783361 (ckn): Build OBX for Sensitivity information "RTN","VAFCSB",110,0) N OBX,SECLVL,SECLOG "RTN","VAFCSB",111,0) S CS=$E(HL("ECH")),OBX="" "RTN","VAFCSB",112,0) S DA=$O(^DGSL(38.1,"B",DFN,"")) I DA="" Q OBX "RTN","VAFCSB",113,0) S DIC=38.1,DR="2",DIQ="SECLOG",DIQ(0)="I,E,N" D EN^DIQ1 "RTN","VAFCSB",114,0) S SECLVL=$G(SECLOG(38.1,DA,2,"I")) I SECLVL="" Q OBX "RTN","VAFCSB",115,0) S SECLVL=SECLVL_CS_$G(SECLOG(38.1,DA,2,"E"))_CS_"L" "RTN","VAFCSB",116,0) S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SECURITY LEVEL"_HL("FS")_HL("FS")_SECLVL_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"F" "RTN","VAFCSB",117,0) Q OBX "RTN","VAFCSB",118,0) ; "RTN","VAFCSB",119,0) NAMEOBX(DFN) ;**876,MVI_3453 (mko): Build OBX for Patient .01 and Name Components "RTN","VAFCSB",120,0) N FS "RTN","VAFCSB",121,0) S FS=HL("FS") "RTN","VAFCSB",122,0) Q "OBX"_FS_FS_"CE"_FS_"NAME COMPONENTS"_FS_FS_$$NAMECOMP(DFN,$E(HL("ECH"))) "RTN","VAFCSB",123,0) ; "RTN","VAFCSB",124,0) NAMEERR(DFN) ;**876,MVI_3453 (mko): Build ERR for Patient .01 and Name Components "RTN","VAFCSB",125,0) N CS,SC "RTN","VAFCSB",126,0) S CS=$E(HL("ECH")),SC=$E(HL("ECH"),4) "RTN","VAFCSB",127,0) Q "ERR"_HL("FS")_CS_CS_CS_SC_$$NAMECOMP(DFN,SC) "RTN","VAFCSB",128,0) ; "RTN","VAFCSB",129,0) NAMECOMP(DFN,DELIM) ;**876,MVI_3453 (mko): Return Patient .01 and Name Components "RTN","VAFCSB",130,0) N DIHELP,DIMSG,DIERR,MSG,NC,NCIEN,NCIENS,NCPTR,TARG "RTN","VAFCSB",131,0) S NC=$P($G(^DPT(DFN,0)),"^") "RTN","VAFCSB",132,0) S NCPTR=$P($G(^DPT(DFN,"NAME")),"^") Q:'NCPTR NC "RTN","VAFCSB",133,0) S NCIEN=$$FIND1^DIC(20,"","","`"_NCPTR,"","","MSG") Q:'NCIEN NC "RTN","VAFCSB",134,0) S NCIENS=NCIEN_"," "RTN","VAFCSB",135,0) D GETS^DIQ(20,NCIENS,"1:5","","TARG","MSG") Q:$G(DIERR) NC "RTN","VAFCSB",136,0) S NC=NC_DELIM_TARG(20,NCIENS,1)_DELIM_TARG(20,NCIENS,2)_DELIM_TARG(20,NCIENS,3)_DELIM_TARG(20,NCIENS,5)_DELIM_TARG(20,NCIENS,4) "RTN","VAFCSB",137,0) Q NC "RTN","VAFCSB",138,0) ; "RTN","VAFCSB",139,0) SEXOR(DFN,OBX) ;build obx for sexual orientation multiple ;**1059, VAMPI-11114 (dri) "RTN","VAFCSB",140,0) ;**1071 VAMPI-13755 (dri) - include status, date created, date last updated "RTN","VAFCSB",141,0) N IENS,OBXCNT,SEXOR,SOCODE,SOCRDT,SOEDDT,SOEXT,SOIEN,SOOBX,SOSTAT "RTN","VAFCSB",142,0) D GETS^DIQ(2,DFN_",",".025*","IE","SEXOR") "RTN","VAFCSB",143,0) I '$D(SEXOR) Q "RTN","VAFCSB",144,0) S OBXCNT=1,IENS="" F S IENS=$O(SEXOR(2.025,IENS)) Q:IENS="" D "RTN","VAFCSB",145,0) .S SOIEN=+$G(SEXOR(2.025,IENS,.01,"I")) I 'SOIEN Q "RTN","VAFCSB",146,0) .S SOCODE=$$GET1^DIQ(47.77,SOIEN_",",1) "RTN","VAFCSB",147,0) .S SOEXT=$G(SEXOR(2.025,IENS,.01,"E")) "RTN","VAFCSB",148,0) .S SOOBX=SOCODE_COMP_SOEXT_COMP_"L" "RTN","VAFCSB",149,0) .S SOSTAT=$G(SEXOR(2.025,IENS,.02,"I")) ;sexual orientation status "RTN","VAFCSB",150,0) .I SOSTAT="" S SOSTAT="A" ;default to "A"ctive if null "RTN","VAFCSB",151,0) .S SOCRDT=$$HLDATE^HLFNC($G(SEXOR(2.025,IENS,.03,"I"))) ;create date "RTN","VAFCSB",152,0) .S SOEDDT=$$HLDATE^HLFNC($G(SEXOR(2.025,IENS,.04,"I"))) ;update date "RTN","VAFCSB",153,0) .S OBX(OBXCNT)="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"Sexual Orientation"_HL("FS")_HL("FS")_SOOBX_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_SOSTAT_HL("FS")_SOEDDT_HL("FS")_HL("FS")_SOCRDT S OBXCNT=OBXCNT+1 "RTN","VAFCSB",154,0) Q "RTN","VAFCSB",155,0) ; "RTN","VAFCSB",156,0) SEXORD(DFN,OBX) ;build obx for sexual orientation description ;**1059, VAMPI-11114 (dri) "RTN","VAFCSB",157,0) N SEXORDES "RTN","VAFCSB",158,0) S SEXORDES=$$GET1^DIQ(2,DFN_",",.0251) "RTN","VAFCSB",159,0) I SEXORDES="" Q "RTN","VAFCSB",160,0) S OBX(1)="OBX"_HL("FS")_HL("FS")_"ST"_HL("FS")_"Sexual Or Description"_HL("FS")_HL("FS")_$E(HL("ECH"),1)_SEXORDES_$E(HL("ECH"),1)_"L" "RTN","VAFCSB",161,0) I $L(OBX(1))>245 D "RTN","VAFCSB",162,0) .S OBX(2)=$E(OBX(1),246,$L(OBX(1))) "RTN","VAFCSB",163,0) .S OBX(1)=$E(OBX(1),1,245) "RTN","VAFCSB",164,0) Q "RTN","VAFCSB",165,0) ; "RTN","VAFCSB",166,0) PRON(DFN,OBX) ;build obx for pronoun multiple ;**1059, VAMPI-11118 (dri) "RTN","VAFCSB",167,0) N IENS,OBXCNT,PRON,PRONCODE,PRONIEN,PRONTYP "RTN","VAFCSB",168,0) D GETS^DIQ(2,DFN_",",".2406*","IE","PRON") "RTN","VAFCSB",169,0) I '$D(PRON) Q "RTN","VAFCSB",170,0) S OBXCNT=1,IENS="" F S IENS=$O(PRON(2.2406,IENS)) Q:IENS="" S PRONIEN=+$G(PRON(2.2406,IENS,.01,"I")) I PRONIEN D "RTN","VAFCSB",171,0) .S PRONCODE=$$GET1^DIQ(47.78,PRONIEN_",",1) "RTN","VAFCSB",172,0) .S PRONTYP=$G(PRON(2.2406,IENS,.01,"E")) "RTN","VAFCSB",173,0) .S OBX(OBXCNT)="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"Pronoun"_HL("FS")_HL("FS")_PRONCODE_$E(HL("ECH"),1)_PRONTYP_$E(HL("ECH"),1)_"L" S OBXCNT=OBXCNT+1 "RTN","VAFCSB",174,0) Q "RTN","VAFCSB",175,0) ; "RTN","VAFCSB",176,0) PROND(DFN,OBX) ;build obx for pronoun description ;**1059, VAMPI-11118 (dri) "RTN","VAFCSB",177,0) N PRONDES "RTN","VAFCSB",178,0) S PRONDES=$$GET1^DIQ(2,DFN_",",.24061) "RTN","VAFCSB",179,0) I PRONDES="" Q "RTN","VAFCSB",180,0) S OBX(1)="OBX"_HL("FS")_HL("FS")_"ST"_HL("FS")_"Pronoun Description"_HL("FS")_HL("FS")_$E(HL("ECH"),1)_PRONDES_$E(HL("ECH"),1)_"L" "RTN","VAFCSB",181,0) I $L(OBX(1))>245 D "RTN","VAFCSB",182,0) .S OBX(2)=$E(OBX(1),246,$L(OBX(1))) "RTN","VAFCSB",183,0) .S OBX(1)=$E(OBX(1),1,245) "RTN","VAFCSB",184,0) Q "RTN","VAFCSB",185,0) ; "RTN","VAFCSB",186,0) LABE() ;BUILD OBX FOR LAST LAB TEST DATE "RTN","VAFCSB",187,0) N OBX S OBX="" "RTN","VAFCSB",188,0) I '$$PATCH^XPDUTL("LR*5.2*295") Q OBX "RTN","VAFCSB",189,0) N LAB,LAB2,EN "RTN","VAFCSB",190,0) S LAB="" K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"C") "RTN","VAFCSB",191,0) S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB=$P($G(^TMP("DGLAB",$J,EN)),"^") "RTN","VAFCSB",192,0) K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"A") "RTN","VAFCSB",193,0) S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2 "RTN","VAFCSB",194,0) K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"M") "RTN","VAFCSB",195,0) S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2 "RTN","VAFCSB",196,0) I LAB'="" D "RTN","VAFCSB",197,0) .S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type "RTN","VAFCSB",198,0) .S $P(OBX,HL("FS"),3)="LAST LAB TEST DATE/TIME" "RTN","VAFCSB",199,0) .S $P(OBX,HL("FS"),11)="F" "RTN","VAFCSB",200,0) .S $P(OBX,HL("FS"),14)=$$HLDATE^HLFNC(LAB) "RTN","VAFCSB",201,0) .S OBX="OBX"_HL("FS")_OBX "RTN","VAFCSB",202,0) Q OBX "RTN","VAFCSB",203,0) ; "RTN","VAFCSB",204,0) RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE "RTN","VAFCSB",205,0) N RET S RET="" "RTN","VAFCSB",206,0) I '$$PATCH^XPDUTL("RA*5.0*76") Q RET "RTN","VAFCSB",207,0) N RAD,RADE "RTN","VAFCSB",208,0) S RAD="",RADE=$$XAMDT^RAO7UTL1(DFN) I +RADE<1 Q RAD "RTN","VAFCSB",209,0) I +RADE>0 D "RTN","VAFCSB",210,0) .S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type "RTN","VAFCSB",211,0) .S $P(RAD,HL("FS"),3)="LAST RADIOLOGY EXAM DATE/TIME" "RTN","VAFCSB",212,0) .S $P(RAD,HL("FS"),11)="F" "RTN","VAFCSB",213,0) .S $P(RAD,HL("FS"),14)=$$HLDATE^HLFNC(RADE) "RTN","VAFCSB",214,0) .S RAD="OBX"_HL("FS")_RAD "RTN","VAFCSB",215,0) Q RAD "RTN","VAFCSB",216,0) ; "RTN","VAFCSB",217,0) PD1() ;BUILD PD1 segment "RTN","VAFCSB",218,0) ;PREFERRED FACILITY -- NOT GOING TO BE PASSED PER IMDQ 9/7/06 "RTN","VAFCSB",219,0) N TEAM,PD1 "RTN","VAFCSB",220,0) S PD1="" "RTN","VAFCSB",221,0) ;S TEAM=$$PREF^DGENPTA(DFN) "RTN","VAFCSB",222,0) ;I TEAM'="" S PD1="PD1"_HL("FS")_HL("FS")_HL("FS")_$$STA^XUAF4(TEAM) "RTN","VAFCSB",223,0) Q PD1 "RTN","VAFCSB",224,0) ; "RTN","VAFCSB",225,0) PV1() ;BUILD PV1 SEGMENT "RTN","VAFCSB",226,0) ;CURRENTLY ADMITTED? "RTN","VAFCSB",227,0) N PV1,VAINDT "RTN","VAFCSB",228,0) S PV1="" "RTN","VAFCSB",229,0) S VAINDT=DT "RTN","VAFCSB",230,0) D INP^VADPT "RTN","VAFCSB",231,0) I $G(VAIN(1))'="" S $P(PV1,HL("FS"),44)=$$HLDATE^HLFNC($P(VAIN(7),"^")),PV1="PV1"_HL("FS")_PV1 "RTN","VAFCSB",232,0) K VAIN "RTN","VAFCSB",233,0) Q PV1 "RTN","VAFCSB",234,0) ; "RTN","VAFCTR") 0^2^B13948610^B12937603 "RTN","VAFCTR",1,0) VAFCTR ;BIR/CMC,ERC,PTD-Monitoring fields for MPI/PD via DG field monitoring ; 1/31/17 11:04am "RTN","VAFCTR",2,0) ;;5.3;Registration;**575,648,653,712,876,902,926,937,944,967,1059,1071**;Aug 13, 1993;Build 4 "RTN","VAFCTR",3,0) Q ; quit if called from the top "RTN","VAFCTR",4,0) ; "RTN","VAFCTR",5,0) MPIPD ; protocol entry point for monitoring fields via DG field monitoring "RTN","VAFCTR",6,0) ; Currently monitoring for fields: "RTN","VAFCTR",7,0) ; 1 ALIAS - .01 of the multiple "RTN","VAFCTR",8,0) ; 2 RACE INFORMATION - .01 of the multiple "RTN","VAFCTR",9,0) ; 6 ETHNICITY INFORMATION - .01 of the multiple "RTN","VAFCTR",10,0) ; 994 MULTIPLE BIRTH INDICATOR "RTN","VAFCTR",11,0) ; .525 POW STAUTS INDICATED? "RTN","VAFCTR",12,0) ; .0906 PSEUDO SSN REASON "RTN","VAFCTR",13,0) ; .121 BAD ADDRESS INDICATOR "RTN","VAFCTR",14,0) ; .133 EMAIL ADDRESS "RTN","VAFCTR",15,0) ; .134 PHONE NUMBER [CELLULAR] "RTN","VAFCTR",16,0) ; .024 SELF IDENTIFIED GENDER **876 "RTN","VAFCTR",17,0) ; 391 TYPE ;**876 "RTN","VAFCTR",18,0) ; 1901 VETERAN Y/N? **876 "RTN","VAFCTR",19,0) ; .323 PERIOD OF SERVICE **876 "RTN","VAFCTR",20,0) ; .352 DEATH ENTERED BY **902 MVI_4735 (jfw) "RTN","VAFCTR",21,0) ; .353 SOURCE OF NOTIFICATION **902 MVI_4735 (jfw) "RTN","VAFCTR",22,0) ; .354 DATE OF DEATH LAST UPDATED **902 MVI_4735 (jfw) "RTN","VAFCTR",23,0) ; .355 LAST EDITED BY **902 MVI_4735 (jfw) "RTN","VAFCTR",24,0) ; .357 SUPPORTING DOCUMENT TYPE **926 STORY 323008 (jfw) "RTN","VAFCTR",25,0) ; .2405 PREFERRED NAME **937 STORY 445457 [Sub-Story 455414] (jfw) "RTN","VAFCTR",26,0) ; .0931 PLACE OF BIRTH COUNTRY **944 STORY 504382 [Sub-Story 513042] (jfw) "RTN","VAFCTR",27,0) ; .0932 PLACE OF BIRTH PROVINCE **944 STORY 504382 [Sub-Story 513042] (jfw) "RTN","VAFCTR",28,0) ; "RTN","VAFCTR",29,0) ;**967 STORY #783361 Sensitivity (jfw) "RTN","VAFCTR",30,0) ; DG SECURITY LOG File #38.1 monitored field: "RTN","VAFCTR",31,0) ; Note: .01 is DINUMED to the PATIENT File #2 "RTN","VAFCTR",32,0) ; 2 SECURITY LEVEL "RTN","VAFCTR",33,0) ; "RTN","VAFCTR",34,0) ;**1059 STORY VAMPI-11114, VAMPI-11118, VAMPI-11120, VAMPI-11121 (jfw) "RTN","VAFCTR",35,0) ; .025 SEXUAL ORIENTATION - .01 of the multiple "RTN","VAFCTR",36,0) ;**1071 STORY VAMPI-13755 (jfw) - Additional SO Fields in multiple "RTN","VAFCTR",37,0) ; .02 STATUS "RTN","VAFCTR",38,0) ; .03 DATE CREATED "RTN","VAFCTR",39,0) ; .04 DATE LAST UPDATED "RTN","VAFCTR",40,0) ; .2406 PRONOUN - .01 of the multiple "RTN","VAFCTR",41,0) ; .0251 SEXUAL ORIENTATION DESCRIPTION "RTN","VAFCTR",42,0) ; .1151 RESIDENTIAL ADDRESS [LINE 1] "RTN","VAFCTR",43,0) ; .1152 RESIDENTIAL ADDRESS [LINE 2] "RTN","VAFCTR",44,0) ; .1153 RESIDENTIAL ADDRESS [LINE 3] "RTN","VAFCTR",45,0) ; .1154 RESIDENTIAL CITY "RTN","VAFCTR",46,0) ; .1155 RESIDENTIAL STATE "RTN","VAFCTR",47,0) ; .1156 RESIDENTIAL ZIP+4 "RTN","VAFCTR",48,0) ; .11571 RESIDENTIAL PROVINCE "RTN","VAFCTR",49,0) ; .11572 RESIDENTIAL POSTAL CODE "RTN","VAFCTR",50,0) ; .11573 RESIDENTIAL COUNTRY "RTN","VAFCTR",51,0) ; .24061 PRONOUN DESCRIPTION "RTN","VAFCTR",52,0) ; 991.11 INDIVIDUAL TAX ID "RTN","VAFCTR",53,0) ; "RTN","VAFCTR",54,0) N MVIRSLT "RTN","VAFCTR",55,0) I $G(DGFILE)'=2&($G(DGFILE)'=2.01)&($G(DGFILE)'=2.02)&($G(DGFILE)'=2.06)&($G(DGFILE)'=38.1)&($G(DGFILE)'=2.025)&($G(DGFILE)'=2.2406) Q "RTN","VAFCTR",56,0) S DGFIELD=$G(DGFIELD) "RTN","VAFCTR",57,0) ;I DGFIELD'=.01&(DGFIELD'=994)&(DGFIELD'=.525)&(DGFIELD'=.0906)&(DGFIELD'=.121)&(DGFIELD'=.133)&(DGFIELD'=.134)&(DGFIELD'=391)&(DGFIELD'=1901)&(DGFIELD'=.323)&(DGFIELD'=.024) Q "RTN","VAFCTR",58,0) ;**902 MVI_4735 (jfw) Add 4 new fields to list (Break apart long If line above) "RTN","VAFCTR",59,0) S MVIRSLT=(DGFIELD'=.01)&(DGFIELD'=.02)&(DGFIELD'=.03)&(DGFIELD'=.04)&(DGFIELD'=994)&(DGFIELD'=.525) "RTN","VAFCTR",60,0) S MVIRSLT=MVIRSLT&(DGFIELD'=.0906)&(DGFIELD'=.121)&(DGFIELD'=.133) "RTN","VAFCTR",61,0) S MVIRSLT=MVIRSLT&(DGFIELD'=.134)&(DGFIELD'=391)&(DGFIELD'=1901)&(DGFIELD'=.323)&(DGFIELD'=.024) "RTN","VAFCTR",62,0) S MVIRSLT=MVIRSLT&(DGFIELD'=.352)&(DGFIELD'=.353)&(DGFIELD'=.354)&(DGFIELD'=.355)&(DGFIELD'=.357) "RTN","VAFCTR",63,0) S MVIRSLT=MVIRSLT&(DGFIELD'=.2405)&(DGFIELD'=.0931)&(DGFIELD'=.0932)&(DGFIELD'=2)&(DGFIELD'=.0251) "RTN","VAFCTR",64,0) S MVIRSLT=MVIRSLT&(DGFIELD'=.1151)&(DGFIELD'=.1152)&(DGFIELD'=.1153)&(DGFIELD'=.1154)&(DGFIELD'=.1155) "RTN","VAFCTR",65,0) S MVIRSLT=MVIRSLT&(DGFIELD'=.1156)&(DGFIELD'=.11571)&(DGFIELD'=.11572)&(DGFIELD'=.11573)&(DGFIELD'=.24061) "RTN","VAFCTR",66,0) S MVIRSLT=MVIRSLT&(DGFIELD'=991.11) "RTN","VAFCTR",67,0) Q:(MVIRSLT) "RTN","VAFCTR",68,0) I $T(AVAFC^VAFCDD01)="" Q "RTN","VAFCTR",69,0) ;The fields below are not multiples "RTN","VAFCTR",70,0) ;I (DGFIELD=994)!(DGFIELD=.525)!(DGFIELD=.0906)!(DGFIELD=.121)!(DGFIELD=.133)!(DGFIELD=.134)!(DGFIELD=.024)!(DGFIELD=391)!(DGFIELD=1901)!(DGFIELD=.323) S VAFCF=DGFIELD_";" D AVAFC^VAFCDD01(DGDA) "RTN","VAFCTR",71,0) ;**902 MVI_4735 (jfw) Add 4 new fields to list (Break apart long If line above) "RTN","VAFCTR",72,0) S MVIRSLT=(DGFIELD=994)!(DGFIELD=.525)!(DGFIELD=.0906)!(DGFIELD=.121)!(DGFIELD=.133) "RTN","VAFCTR",73,0) S MVIRSLT=MVIRSLT!(DGFIELD=.134)!(DGFIELD=.024)!(DGFIELD=391)!(DGFIELD=1901)!(DGFIELD=.323) "RTN","VAFCTR",74,0) S MVIRSLT=MVIRSLT!(DGFIELD=.352)!(DGFIELD=.353)!(DGFIELD=.354)!(DGFIELD=.355)!(DGFIELD=.357) "RTN","VAFCTR",75,0) S MVIRSLT=MVIRSLT!(DGFIELD=.2405)!(DGFIELD=.0931)!(DGFIELD=.0932)!(DGFIELD=.0251)!(DGFIELD=.1151) "RTN","VAFCTR",76,0) S MVIRSLT=MVIRSLT!(DGFIELD=.1152)!(DGFIELD=.1153)!(DGFIELD=.1154)!(DGFIELD=.1155)!(DGFIELD=.1156) "RTN","VAFCTR",77,0) S MVIRSLT=MVIRSLT!(DGFIELD=.11571)!(DGFIELD=.11572)!(DGFIELD=.11573)!(DGFIELD=.24061)!(DGFIELD=991.11) "RTN","VAFCTR",78,0) I MVIRSLT S VAFCF=DGFIELD_";" D AVAFC^VAFCDD01(DGDA) "RTN","VAFCTR",79,0) ;The fields below ARE multiples "RTN","VAFCTR",80,0) I DGFILE=2.01 S VAFCF="1;" D AVAFC^VAFCDD01(DGDA(1)) ;ALIAS "RTN","VAFCTR",81,0) I DGFILE=2.02 S VAFCF="2.02,.01;" D AVAFC^VAFCDD01(DGDA(1)) ;RACE INFORMATION "RTN","VAFCTR",82,0) I DGFILE=2.06 S VAFCF="2.06,.01;" D AVAFC^VAFCDD01(DGDA(1)) ;ETHNICITY INFORMATION "RTN","VAFCTR",83,0) I DGFILE=2.025 S VAFCF="2.025,"_DGFIELD_";" D AVAFC^VAFCDD01(DGDA(1)) ;SEXUAL ORIENTATION "RTN","VAFCTR",84,0) I DGFILE=2.2406 S VAFCF="2.2406,.01;" D AVAFC^VAFCDD01(DGDA(1)) ;PRONOUN "RTN","VAFCTR",85,0) ;Process field for different File **967 (jfw) "RTN","VAFCTR",86,0) I DGFILE=38.1 S VAFCF="38.1,2;" D AVAFC^VAFCDD01(DGDA) ;Sensitivity Info "RTN","VAFCTR",87,0) Q "UP",2,2.025,-1) 2^.025 "UP",2,2.025,0) 2.025 "VER") 8.0^22.2 "^DD",2,2,.025,0) SEXUAL ORIENTATION^2.025P^^.025;0 "^DD",2,2,.025,21,0) ^.001^2^2^3220428^^^^ "^DD",2,2,.025,21,1,0) The Sexual Orientation identifies the identities of the patient in "^DD",2,2,.025,21,2,0) relation to the gender to which they associate with. "^DD",2,2,.0251,0) SEXUAL ORIENTATION DESCRIPTION^FJ255a^^.241;1^K:$L(X)>255!($L(X)<3) X "^DD",2,2,.0251,3) Enter the description (3-255 characters) of the specified 'Other' Sexual Orientation associated with the patient. "^DD",2,2,.0251,21,0) ^.001^3^3^3210628^^ "^DD",2,2,.0251,21,1,0) The SEXUAL ORIENTATION DESCRIPTION field defines the 'Other' specified "^DD",2,2,.0251,21,2,0) Sexual Orientation identity of the patient in relation to the gender to "^DD",2,2,.0251,21,3,0) which they associate with. "^DD",2,2,.0251,"AUDIT") y "^DD",2,2,.0251,"DT") 3220426 "^DD",2,2.025,0) SEXUAL ORIENTATION SUB-FIELD^^.06^6 "^DD",2,2.025,0,"NM","SEXUAL ORIENTATION") "^DD",2,2.025,.01,0) SEXUAL ORIENTATION^MP47.77'a^DG(47.77,^0;1^Q "^DD",2,2.025,.01,1,0) ^.1^^-1 "^DD",2,2.025,.01,1,1,0) 2.025^B "^DD",2,2.025,.01,1,1,1) S ^DPT(DA(1),.025,"B",$E(X,1,30),DA)="" "^DD",2,2.025,.01,1,1,2) K ^DPT(DA(1),.025,"B",$E(X,1,30),DA) "^DD",2,2.025,.01,3) Select the appropriate SEXUAL ORIENTATION TYPE from the list that identifies the identity of the patient in relation to the gender to which they associate with. "^DD",2,2.025,.01,21,0) ^.001^2^2^3220119^^ "^DD",2,2.025,.01,21,1,0) The Sexual Orientation selected from the available list identifies the "^DD",2,2.025,.01,21,2,0) identity in relation to the gender to which the patient associates with. "^DD",2,2.025,.01,"AUDIT") y "^DD",2,2.025,.01,"DT") 3220426 "^DD",2,2.025,.02,0) STATUS^Sa^A:ACTIVE;I:INACTIVE;E:ENTERED IN ERROR;^0;2^Q "^DD",2,2.025,.02,3) Select the code that identifies the current status for this Sexual Orientation. "^DD",2,2.025,.02,21,0) ^^2^2^3220125^ "^DD",2,2.025,.02,21,1,0) This field is used to note/indicate the current status for this Sexual "^DD",2,2.025,.02,21,2,0) Orientation of the patient. "^DD",2,2.025,.02,"AUDIT") y "^DD",2,2.025,.02,"DT") 3220426 "^DD",2,2.025,.03,0) DATE CREATED^D^^0;3^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",2,2.025,.03,3) Enter the date when the Sexual Orientation was added to the patient's record. "^DD",2,2.025,.03,21,0) ^.001^2^2^3220119^^^ "^DD",2,2.025,.03,21,1,0) The date value entered identifies when this Sexual Orientation was added "^DD",2,2.025,.03,21,2,0) to the patient's record. "^DD",2,2.025,.03,"DT") 3220426 "^DD",2,2.025,.04,0) DATE LAST UPDATED^Da^^0;4^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",2,2.025,.04,1,0) ^.1^^0 "^DD",2,2.025,.04,3) Enter the date when this Sexual Orientation information was last updated. "^DD",2,2.025,.04,21,0) ^.001^2^2^3220428^^^^ "^DD",2,2.025,.04,21,1,0) The date value entered identifies when this Sexual Orientation was last "^DD",2,2.025,.04,21,2,0) updated on the patient's record. "^DD",2,2.025,.04,"AUDIT") y "^DD",2,2.025,.04,"DT") 3220426 "^DD",2,2.025,.05,0) NOTE^P8925'a^TIU(8925,^0;5^Q "^DD",2,2.025,.05,3) Select the appropriate TIU DOCUMENT that is associated with this Sexual Orientation. "^DD",2,2.025,.05,21,0) ^^3^3^3220125^ "^DD",2,2.025,.05,21,1,0) This field specifies the Internal Entry Number (IEN) in the TIU DOCUMENT "^DD",2,2.025,.05,21,2,0) (#8925) file that is associated with this Sexual Orientation on the "^DD",2,2.025,.05,21,3,0) patient's record. "^DD",2,2.025,.05,"AUDIT") y "^DD",2,2.025,.05,"DT") 3220512 "^DD",2,2.025,.06,0) TYPE OF UPDATE^S^L:LOCAL;R:REMOTE;^0;6^Q "^DD",2,2.025,.06,3) Select the code that identifies how this Sexual Orientation was added/updated. "^DD",2,2.025,.06,21,0) ^.001^4^4^3220425^^^^ "^DD",2,2.025,.06,21,1,0) 'L'ocal denotes the Sexual Orientations were added/updated by the "^DD",2,2.025,.06,21,2,0) Local VistA Instance. "^DD",2,2.025,.06,21,3,0) 'R'emote denotes the Sexual Orientations were added/updated via a "^DD",2,2.025,.06,21,4,0) Remote VistA Instance, Self Service App or Website via HL7. "^DD",2,2.025,.06,"DT") 3220426 "BLD",3746,6) ^940 **END** **END**