Routine: VAFCPDAT

VAFCPDAT ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 7/12/16 11:11am

 ;;5.3;Registration;**333,414,474,505,707,712,837,863,876,902,926,937,950,1059,1071,1112**;Aug 13, 1993;Build 1

 ;Registration has IA #3299 for MPI/PD to call START^VAFCPDAT

 ;variable DFN is not NEWed or KILLed in this routine as that variable is passed in

MAIN ; Entry point with device call

 S NOTRPC=1

 K ZTSAVE S ZTSAVE("DFN")=""

 D EN^XUTMDEVQ("START^VAFCPDAT","Print MPI/PD Patient Data",.ZTSAVE)

 K NOTRPC

START ;Entry point without device call, used for RPC calls

 N X S X="MPIF001" X ^%ZOSF("TEST") I '$T W !,"MPI not installed." G QUIT  ;**863 - MVI_2351 (ptd)

 S $P(LN,"=",80)="",$P(LN2,"=",60)="",QFLG=0

 D NOW^%DTC S HDT=$$FMTE^XLFDT($E(%,1,12))

 S SITE=$$SITE^VASITE(),SITENAM=$P(SITE,"^",2),SITENUM=$P(SITE,"^",3),SITEIEN=$P(SITE,"^")

 I +DFN<0 D  Q

 .I $D(NOTRPC) W @IOF,!," "

 .W !,"ICN ",$G(ICN)," does not exist at ",SITENAM,"."

 .W !,"Search date: ",HDT,!,LN

 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;"

 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"

 S DA=DFN,DIQ(0)="EI",DIQ="DNODE" D EN^DIQ1 K DIC,DR,DA,DIQ  ;**707,712,863,876;1059

 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

 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

 S NAME=$G(DNODE(2,DFN,.01,"E")),SSN=$G(DNODE(2,DFN,.09,"E")),SSNVER=$G(DNODE(2,DFN,.0907,"E"))  ;**707

 S DOB=$$FMTE^XLFDT($G(DNODE(2,DFN,.03,"I")))

 S MBI=$G(DNODE(2,DFN,994,"I")),MBI=$S(MBI="Y":"YES",MBI="N":"NO",1:"NULL")  ;**707

 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)

 S CLAIM=$G(DNODE(2,DFN,.313,"E")) S:CLAIM="" CLAIM="None"

 S BAI=$G(DNODE(2,DFN,.121,"E"))  ;**712

 S STR1=$G(DNODE(2,DFN,.111,"E")),STR2=$G(DNODE(2,DFN,.112,"E")),STR3=$G(DNODE(2,DFN,.113,"E"))

 S CTY=$G(DNODE(2,DFN,.114,"E")),ST=$G(DNODE(2,DFN,.115,"E")),ZIP=$G(DNODE(2,DFN,.1112,"E"))

 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)

 S PROVINCE=$G(DNODE(2,DFN,.1171,"E")),POSTCODE=$G(DNODE(2,DFN,.1172,"E"))

 ;**1071 Story 13802 (jfw) - Retrieve/Display WorkPhone (.132) and CellPhone (.134)

 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

 S MNODE=$$MPINODE^MPIFAPI(DFN) I +MNODE=-1 S MNODE="^^^^^^^^"

 S (ICN,SCN,SCORE,SCRDT,DIFF,TIN,FIN)=""   ;**837, MVI_883

 S ICN=$$GETICN^MPIF001(DFN) S:(+ICN=-1) ICN="None" ;**863 - MVI_2351 (ptd)

 ;**926 - Story 323009 (ckn): DOD fields

 I DOD'="" D

 .;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

 . 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"))

 . S DODD=$G(DNODE(2,DFN,.357,"E")),DODOPT=$G(DNODE(2,DFN,.358,"E"))

 ;S CMOR=$$GET1^DIQ(4,+$P($G(MNODE),"^",3)_",",.01) S:CMOR="" CMOR="None"    ;removed for **837, MVI_918

 I $E(ICN,1,3)=SITENUM S GOT=0 I $P($G(MNODE),"^",4)=""!('$D(^DPT("AICNL",1,DFN))) S ICN=ICN_"**"

 S TIN=$P($G(MNODE),"^",8),FIN=$P($G(MNODE),"^",9) ;**837, MVI_883

 ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

 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"))

 S RESZP=$G(DNODE(2,DFN,.1156,"E")),RESP=$G(DNODE(2,DFN,.11571,"E")),RESPC=$G(DNODE(2,DFN,.11572,"E"))

 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)

 S ITIN=$G(DNODE(2,DFN,991.11,"E")),SXOD=$G(DNODE(2,DFN,.0251,"E")),PRND=$G(DNODE(2,DFN,.24061,"E"))

 I $D(NOTRPC) W @IOF,!

 W !,"MPI/PD Data for: ",NAME,"  (DFN #",DFN,")"

 ; check for patient sensitivity and user security

 N RESULT,RGSENS,SENSTV,DA,DR,DIC,DIQ,VAFCSEN

 D PTSEC^DGSEC4(.RESULT,DFN,0,"MPI/PD Patient Inquiry^MPI/PD Patient Inquiry")

 I RESULT(1)=-1 W !!,"Access denied: Required parameters not defined" G QUIT

 I RESULT(1)>0 W ?50,"***PATIENT MARKED SENSITIVE***"

 I RESULT(1)=3 W !!,"Access not allowed on your own PATIENT (#2) file entry" G QUIT

 I RESULT(1)=4 W !!,"Access denied: Your SSN is not defined" G QUIT

 I RESULT(1)<3 D

 . I RESULT(1)=1 D NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",2) ;IA #3027

 . I RESULT(1)=2 D NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",3) ;IA #3027

 W !,"Printed ",HDT," at ",SITENAM,!,LN

 S $Y=$Y+1

 ;next 7 lines modified for **707

 W !,"ICN : ",ICN  ;CMOR removed  **837, MVI_918

 W !,"SSN : ",SSN

 I SSNVER'="" W !?9,"SSN Verification Status: ",SSNVER

 I PREAS'="" W !?9,"Pseudo SSN Reason: ",PREAS

 I ITIN'="" W !?9,"Individual Tax ID: ",ITIN ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

 ; Story 603957 (elz) change sex to birth sex, lined up with DOB and DOD at the same time

 W !,"Birth Sex    :  ",SEX

 ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

 ;**1071 VAMPI-13755 (jfw) - Display additional SO Info

 ;SEXUAL ORIENTATION

 I $O(^DPT(DFN,.025,0))'="" W !,"Sexual Orientation: " D

 .S EN=0 F  S EN=$O(^DPT(DFN,.025,EN)) Q:'EN  D

 ..N VAFCSOI D GETS^DIQ(2.025,EN_","_DFN,"*",,"VAFCSOI")

 ..W ?20,VAFCSOI(2.025,EN_","_DFN_",",.01)_" ("_VAFCSOI(2.025,EN_","_DFN_",",.02)_")"

 ..W !?25,"Date Created: ",?44,VAFCSOI(2.025,EN_","_DFN_",",.03)

 ..W !?25,"Date Last Updated: "_VAFCSOI(2.025,EN_","_DFN_",",.04)

 ..W:(+$O(^DPT(DFN,.025,EN))) !

 I SXOD'="" W !,"Sexual Orientation Free Text: ",SXOD

 ;PRONOUN

 I $O(^DPT(DFN,.2406,0))'="" W !,"Pronoun: " D

 .S EN=0 F  S EN=$O(^DPT(DFN,.2406,EN)) Q:'EN  D

 ..S PRN=$G(^DPT(DFN,.2406,EN,0))

 ..W ?20,$P($G(^DG(47.78,PRN,0)),"^") W:(+$O(^DPT(DFN,.2406,EN))) !

 I PRND'="" W !,"Pronoun Description: ",PRND

 I SIGEN'="" W !,"Self-Identified Gender Identity: ",SIGEN  ;**876 - MVI_3432 (cml)  **902 - MVI_4730 (cml) MOVED HERE IN 1059

 W !,"Claim #      :  ",CLAIM

 W !,"Date of Birth:  ",DOB

 ;**926 - Story 323009 (ckn): DOD fields

 I DOD]"" D

 . W !,"Date of Death:  ",DOD

 . I DODENTBY]"" W !,?15,"Entered By: ",?42,DODENTBY

 . I DODSRC]"" W !,?15,"Source of Notification: ",?42,DODSRC

 . I DODLUPD]"" W !,?15,"Last Updated: ",?42,DODLUPD

 . I DODLEBY]"" W !,?15,"Last Edited By: ",?42,DODLEBY

 . I DODD]"" W !,?15,"Supporting Document Type: ",?42,DODD

 . I DODOPT]"" W !,?15,"Option Used: ",?42,DODOPT

 I MBI]"" W !,"Multiple Birth Indicator: ",MBI  ;**707

 I TIN]"" W !,"DoD Temporary ID Number : ",TIN  ;**837, MVI_883

 I FIN]"" W !,"DoD Foreign ID Number   : ",FIN  ;**837, MVI_883

 W !,"Correspondence Address:" I BAI'="" W " (Bad Address Indicator: ",BAI,")" ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

 I STR1'="" W !?9,STR1

 I STR2'="" W !?9,STR2

 I STR3'="" W !?9,STR3

 I COUNTRY=""!(CCODE="USA") D   ;USA Address  **863 - MVI_1902 (ptd)

 .I CTY]"" W !?9,$E(CTY,1,20)_", "_$G(ST)_" "_$G(ZIP)

 I COUNTRY]"",CCODE'="USA" D   ;Foreign Address

 .I CTY]""!(PROVINCE]"")!(POSTCODE]"") D

 ..I PROVINCE]"" W !?9,CTY_", "_PROVINCE_" ("_CNAME_")  "_POSTCODE

 ..I PROVINCE="" W !?9,CTY_", "_"("_CNAME_")  "_POSTCODE

 W !,"Residential Address: "

 I REST1'="" W !?9,REST1

 I REST2'="" W !?9,REST2

 I REST3'="" W !?9,REST3

 I $G(RESCN)=""!($G(RCCODE)="USA") I RESCTY]"" W !?9,$E(RESCTY,1,20)_", "_$G(RESST)_" "_$G(RESZP)

 I RESCN'="",$G(RCCODE)'="USA" D   ;Foreign Address

 .I RESCTY]""!(RESP]"")!(RESPC]"") D

 ..I RESP]"" W !?9,RESCTY_", "_RESP_" ("_RCNAME_")  "_RESPC

 ..I RESP="" W !?9,RESCTY_", "_"("_RCNAME_")  "_RESPC

 I PHN'="" W !,"Phone #: ",PHN

 ;**1071 Story 13802 (jfw) - Retrieve/Display WorkPhone (.132) and CellPhone (.134)

 I WPHN'="" W !,"Work  #: ",WPHN

 I CPHN'="" W !,"Cell  #: ",CPHN

 I $G(IOSL)<30&($E(IOST,1,2)="C-") D

 .I $Y>23 D

 ..S DIR(0)="E" D  D ^DIR K DIR I 'Y S QFLG=1

 ...S SS=22-$Y F JJ=1:1:SS W !

 ..S $Y=0

 I QFLG=1 G QUIT

TF ;List Treating Facilities for this patient

 D TFHDR

 K TFARR

 S TF=0 F  S TF=$O(^DGCN(391.91,"APAT",DFN,TF)) Q:'TF  D

 .S TFIEN=$O(^DGCN(391.91,"APAT",DFN,TF,0))

 . S DIC="^DGCN(391.91,",DR=".02;.03;.07",DA=TFIEN,DIQ(0)="EI",DIQ="TFDATA"

 . D EN^DIQ1 K DIC,DA,DR,DIQ

 . S INST="",STATION=""

 . S INST=$G(TFDATA(391.91,TFIEN,.02,"I"))

 . I INST'="" D

 .. S DIC=4,DR="99",DA=INST,DIQ(0)="E",DIQ="STA"

 .. D EN^DIQ1 K DIC,DA,DR,DIQ

 .. S STATION=$G(STA(4,INST,99,"E"))

 . S TFNM=$G(TFDATA(391.91,TFIEN,.02,"E"))

 . S LSTDT=$G(TFDATA(391.91,TFIEN,.03,"I")) S:LSTDT="" LSTDT="none found"

 . S LSTSORT=9999999

 . I +LSTDT S LSTSORT=9999999-LSTDT,LSTDT=$$FMTE^XLFDT($E(LSTDT,1,12))

 . S REACODE=$G(TFDATA(391.91,TFIEN,.07,"E")) S REASON="none found"

 . I REACODE'="" D

 .. S DIC="^VAT(391.72,",DIC(0)="Z",X=REACODE D ^DIC K DIC,X

 .. S REASON=$P($G(Y(0)),"^",4)

 . S TFARR(LSTSORT,TFNM)=TFIEN_"^"_REASON_"^"_$G(STATION)_"^"_LSTDT

 I '$D(TFARR) W !,"No Treating Facilities found." G SUB

 S LSTSORT=0 F  S LSTSORT=$O(TFARR(LSTSORT)) Q:'LSTSORT  D  G:QFLG QUIT

 .S TFNM="" F  S TFNM=$O(TFARR(LSTSORT,TFNM)) Q:TFNM=""  D  Q:QFLG

 ..S REASON=$P(TFARR(LSTSORT,TFNM),"^",2)

 ..S STATION=$P(TFARR(LSTSORT,TFNM),"^",3)

 ..S LSTDT=$P(TFARR(LSTSORT,TFNM),"^",4)

 ..I $Y+3>IOSL&($E(IOST,1,2)="C-") D  Q:QFLG

 ...S LNQ=22 D SS Q:QFLG

 ...W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2 D TFHDR

 ..W !,$E(TFNM,1,20),?22,$G(STATION),?32,LSTDT,?54,REASON

SUB ;removed listing of subscribers for RG*1.0*23

HIS ;find ICN history

 I '$O(^DPT(DFN,"MPIFHIS",0)) G CONT

 I $Y+4>IOSL&($E(IOST,1,2)="C-") D  G:QFLG QUIT

 .S LNQ=22 D SS Q:QFLG

 .W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2

 D ICNHDR

 S HIS=0 F  S HIS=$O(^DPT(DFN,"MPIFHIS",HIS)) Q:'HIS  D  G:QFLG QUIT

 .S DIC=2,DR="992",DR(2.0992)=".01;1;3",DA=DFN,DA(2.0992)=HIS ;**863 - MVI_2351 (ptd)

 .S DIQ(0)="E",DIQ="HISNODE"

 .D EN^DIQ1 K DIC,DA,DR,DIQ

 .S HISICN=$G(HISNODE(2.0992,HIS,.01,"E"))

 .S HISCHK=$G(HISNODE(2.0992,HIS,1,"E")) ;**863 - MVI_2351 (ptd) history checksum

 .S HFULLICN=HISICN_$S(HISCHK]"":"V"_HISCHK,1:"") ;**863 - MVI_2351 (ptd) History full ICN

 .S HISDT=$G(HISNODE(2.0992,HIS,3,"E"))

 .I $Y+3>IOSL&($E(IOST,1,2)="C-") D  Q:QFLG

 ..S LNQ=22 D SS Q:QFLG

 ..W @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2 D ICNHDR

 .W !,HFULLICN I HISDT]"" W "  - changed ",HISDT ;**863 - MVI_2351 (ptd)

CONT ;Continue to VAFCPDT2 for extended data

 ;D CMORHIS^VAFCPDT2  ;CMOR History removed, called changed to EXT^VAFCPDT2  **837, MVI_918

 D EXT^VAFCPDT2

DONE ;

 I QFLG G QUIT

 I ($E(IOST,1,2)="C-") S LNQ=24 D SS

QUIT ;

 K %,CMOR,DIC,DIR,DIRUT,DNODE,GOT,HDT,HFULLICN,HIS,HISCHK,HISDT,HISICN,JJ,LIEN

 K LINST,LN,LSTDT,MNODE,REACODE,REASON,SCN,SCORE,SITE,SITEIEN,SITENAM,SITENUM

 K SS,SUBN,SUBARR,TERM,TERMDT,TF,TFARR,TFDATA,TFIEN,TFNM,Y,D,CHG,CHGNODE

 K HISNODE,DIFF,INST,RGDFN,SCRDT,STATION,STA,LN2,NAME,LSTSORT,LNQ,QFLG,MBI

TFHDR ;

 W !!,"Treating Facilities:",?22,"Station:",?32,"DT Last Treated",?54,"Event Reason"

 W !,"--------------------",?22,"--------",?32,"---------------",?54,"------------"

ICNHDR W !!,"ICN History:",!,"------------"

SS S DIR(0)="E" D  D ^DIR K DIR I 'Y S QFLG=1

 .S SS=LNQ-$Y F JJ=1:1:SS W !

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCPDAT   11988     printed  Apr 23, 2025@19:16:11                                                                                                                                                                                                   Page 2

VAFCPDAT  ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 7/12/16 11:11am

 +1       ;;5.3;Registration;**333,414,474,505,707,712,837,863,876,902,926,937,950,1059,1071,1112**;Aug 13, 1993;Build 1

 +2       ;Registration has IA #3299 for MPI/PD to call START^VAFCPDAT

 +3       ;

 +4       ;variable DFN is not NEWed or KILLed in this routine as that variable is passed in

 +5       ;

MAIN      ; Entry point with device call

 +1        SET NOTRPC=1

 +2        KILL ZTSAVE

           SET ZTSAVE("DFN")=""

 +3        DO EN^XUTMDEVQ("START^VAFCPDAT","Print MPI/PD Patient Data",.ZTSAVE)

 +4        KILL NOTRPC

 +5        QUIT

 +6       ;

START     ;Entry point without device call, used for RPC calls

 +1       ;**863 - MVI_2351 (ptd)

           NEW X

           SET X="MPIF001"

           XECUTE ^%ZOSF("TEST")

           IF '$TEST

               WRITE !,"MPI not installed."

               GOTO QUIT

 +2        SET $PIECE(LN,"=",80)=""

           SET $PIECE(LN2,"=",60)=""

           SET QFLG=0

 +3        DO NOW^%DTC

           SET HDT=$$FMTE^XLFDT($EXTRACT(%,1,12))

 +4        SET SITE=$$SITE^VASITE()

           SET SITENAM=$PIECE(SITE,"^",2)

           SET SITENUM=$PIECE(SITE,"^",3)

           SET SITEIEN=$PIECE(SITE,"^")

 +5        IF +DFN<0

               Begin DoDot:1

 +6                IF $DATA(NOTRPC)

                       WRITE @IOF,!," "

 +7                WRITE !,"ICN ",$GET(ICN)," does not exist at ",SITENAM,"."

 +8                WRITE !,"Search date: ",HDT,!,LN

               End DoDot:1

               QUIT

 +9        SET DIC=2

           SET DR=".01;.02;.03;.09;.111;.112;.113;.114;.115;.1112;.131;.132;.134;.313;.351;994;.0907;.0906;.121;.1171;.1172;.1173;"

 +10       SET 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"

 +11      ;**707,712,863,876;1059

           SET DA=DFN

           SET DIQ(0)="EI"

           SET DIQ="DNODE"

           DO EN^DIQ1

           KILL DIC,DR,DA,DIQ

 +12      ;**707,712,837,863,876

           NEW 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

 +13      ;**926 Story 323009 (ckn) **1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

           NEW DODD,DODENTBY,DODSRC,DODLUPD,DODLEBY,DODOPT,REST1,REST2,REST3,RESCTY,RESST,RESZP,RESP,RESPC,RESCN,ITIN,SXOD,SXO,PRN,PRND,EN,RCCODE,RCNAME

 +14      ;**707

           SET NAME=$GET(DNODE(2,DFN,.01,"E"))

           SET SSN=$GET(DNODE(2,DFN,.09,"E"))

           SET SSNVER=$GET(DNODE(2,DFN,.0907,"E"))

 +15       SET DOB=$$FMTE^XLFDT($GET(DNODE(2,DFN,.03,"I")))

 +16      ;**707

           SET MBI=$GET(DNODE(2,DFN,994,"I"))

           SET MBI=$SELECT(MBI="Y":"YES",MBI="N":"NO",1:"NULL")

 +17      ;**876 - MVI_3432 (cml)

           SET SEX=$GET(DNODE(2,DFN,.02,"E"))

           SET SIGEN=$GET(DNODE(2,DFN,.024,"E"))

           SET DOD=$GET(DNODE(2,DFN,.351,"E"))

 +18       SET CLAIM=$GET(DNODE(2,DFN,.313,"E"))

           if CLAIM=""

               SET CLAIM="None"

 +19      ;**712

           SET BAI=$GET(DNODE(2,DFN,.121,"E"))

 +20       SET STR1=$GET(DNODE(2,DFN,.111,"E"))

           SET STR2=$GET(DNODE(2,DFN,.112,"E"))

           SET STR3=$GET(DNODE(2,DFN,.113,"E"))

 +21       SET CTY=$GET(DNODE(2,DFN,.114,"E"))

           SET ST=$GET(DNODE(2,DFN,.115,"E"))

           SET ZIP=$GET(DNODE(2,DFN,.1112,"E"))

 +22      ;**863 - MVI_1902 (ptd)

           SET COUNTRY=$GET(DNODE(2,DFN,.1173,"I"))

           SET (CCODE,CNAME)=""

           IF COUNTRY]""

               SET CCODE=$$GET1^DIQ(779.004,+COUNTRY_",",.01)

               SET CNAME=$$GET1^DIQ(779.004,+COUNTRY_",",1.3)

 +23       SET PROVINCE=$GET(DNODE(2,DFN,.1171,"E"))

           SET POSTCODE=$GET(DNODE(2,DFN,.1172,"E"))

 +24      ;**1071 Story 13802 (jfw) - Retrieve/Display WorkPhone (.132) and CellPhone (.134)

 +25      ;**707

           SET PHN=$GET(DNODE(2,DFN,.131,"E"))

           SET WPHN=$GET(DNODE(2,DFN,.132,"E"))

           SET CPHN=$GET(DNODE(2,DFN,.134,"E"))

           SET PREAS=$GET(DNODE(2,DFN,.0906,"E"))

 +26       SET MNODE=$$MPINODE^MPIFAPI(DFN)

           IF +MNODE=-1

               SET MNODE="^^^^^^^^"

 +27      ;**837, MVI_883

           SET (ICN,SCN,SCORE,SCRDT,DIFF,TIN,FIN)=""

 +28      ;**863 - MVI_2351 (ptd)

           SET ICN=$$GETICN^MPIF001(DFN)

           if (+ICN=-1)

               SET ICN="None"

 +29      ;**926 - Story 323009 (ckn): DOD fields

 +30       IF DOD'=""

               Begin DoDot:1

 +31      ;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

 +32               SET DODENTBY=$GET(DNODE(2,DFN,.352,"E"))

                   SET DODSRC=$GET(DNODE(2,DFN,.353,"E"))

                   SET DODLUPD=$GET(DNODE(2,DFN,.354,"E"))

                   SET DODLEBY=$GET(DNODE(2,DFN,.355,"E"))

 +33               SET DODD=$GET(DNODE(2,DFN,.357,"E"))

                   SET DODOPT=$GET(DNODE(2,DFN,.358,"E"))

               End DoDot:1

 +34      ;S CMOR=$$GET1^DIQ(4,+$P($G(MNODE),"^",3)_",",.01) S:CMOR="" CMOR="None"    ;removed for **837, MVI_918

 +35       IF $EXTRACT(ICN,1,3)=SITENUM

               SET GOT=0

               IF $PIECE($GET(MNODE),"^",4)=""!('$DATA(^DPT("AICNL",1,DFN)))

                   SET ICN=ICN_"**"

 +36      ;**837, MVI_883

           SET TIN=$PIECE($GET(MNODE),"^",8)

           SET FIN=$PIECE($GET(MNODE),"^",9)

 +37      ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

 +38       SET REST1=$GET(DNODE(2,DFN,.1151,"E"))

           SET REST2=$GET(DNODE(2,DFN,.1152,"E"))

           SET REST3=$GET(DNODE(2,DFN,.1153,"E"))

           SET RESCTY=$GET(DNODE(2,DFN,.1154,"E"))

           SET RESST=$GET(DNODE(2,DFN,.1155,"E"))

 +39       SET RESZP=$GET(DNODE(2,DFN,.1156,"E"))

           SET RESP=$GET(DNODE(2,DFN,.11571,"E"))

           SET RESPC=$GET(DNODE(2,DFN,.11572,"E"))

 +40       SET RESCN=$GET(DNODE(2,DFN,.11573,"I"))

           SET (RCCODE,RCNAME)=""

           IF RESCN]""

               SET RCCODE=$$GET1^DIQ(779.004,+RESCN_",",.01)

               SET RCNAME=$$GET1^DIQ(779.004,+RESCN_",",1.3)

 +41       SET ITIN=$GET(DNODE(2,DFN,991.11,"E"))

           SET SXOD=$GET(DNODE(2,DFN,.0251,"E"))

           SET PRND=$GET(DNODE(2,DFN,.24061,"E"))

 +42      ;

 +43       IF $DATA(NOTRPC)

               WRITE @IOF,!

 +44       WRITE !,"MPI/PD Data for: ",NAME,"  (DFN #",DFN,")"

 +45      ; check for patient sensitivity and user security

 +46       NEW RESULT,RGSENS,SENSTV,DA,DR,DIC,DIQ,VAFCSEN

 +47       DO PTSEC^DGSEC4(.RESULT,DFN,0,"MPI/PD Patient Inquiry^MPI/PD Patient Inquiry")

 +48       IF RESULT(1)=-1

               WRITE !!,"Access denied: Required parameters not defined"

               GOTO QUIT

 +49       IF RESULT(1)>0

               WRITE ?50,"***PATIENT MARKED SENSITIVE***"

 +50       IF RESULT(1)=3

               WRITE !!,"Access not allowed on your own PATIENT (#2) file entry"

               GOTO QUIT

 +51       IF RESULT(1)=4

               WRITE !!,"Access denied: Your SSN is not defined"

               GOTO QUIT

 +52       IF RESULT(1)<3

               Begin DoDot:1

 +53      ;IA #3027

                   IF RESULT(1)=1

                       DO NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",2)

 +54      ;IA #3027

                   IF RESULT(1)=2

                       DO NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",3)

               End DoDot:1

 +55       WRITE !,"Printed ",HDT," at ",SITENAM,!,LN

 +56       SET $Y=$Y+1

 +57      ;next 7 lines modified for **707

 +58      ;CMOR removed  **837, MVI_918

           WRITE !,"ICN : ",ICN

 +59       WRITE !,"SSN : ",SSN

 +60       IF SSNVER'=""

               WRITE !?9,"SSN Verification Status: ",SSNVER

 +61       IF PREAS'=""

               WRITE !?9,"Pseudo SSN Reason: ",PREAS

 +62      ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

           IF ITIN'=""

               WRITE !?9,"Individual Tax ID: ",ITIN

 +63      ; Story 603957 (elz) change sex to birth sex, lined up with DOB and DOD at the same time

 +64       WRITE !,"Birth Sex    :  ",SEX

 +65      ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

 +66      ;**1071 VAMPI-13755 (jfw) - Display additional SO Info

 +67      ;SEXUAL ORIENTATION

 +68       IF $ORDER(^DPT(DFN,.025,0))'=""

               WRITE !,"Sexual Orientation: "

               Begin DoDot:1

 +69               SET EN=0

FOR

                       SET EN=$ORDER(^DPT(DFN,.025,EN))

                       if 'EN

                           QUIT

                       Begin DoDot:2

 +70                       NEW VAFCSOI

                           DO GETS^DIQ(2.025,EN_","_DFN,"*",,"VAFCSOI")

 +71                       WRITE ?20,VAFCSOI(2.025,EN_","_DFN_",",.01)_" ("_VAFCSOI(2.025,EN_","_DFN_",",.02)_")"

 +72                       WRITE !?25,"Date Created: ",?44,VAFCSOI(2.025,EN_","_DFN_",",.03)

 +73                       WRITE !?25,"Date Last Updated: "_VAFCSOI(2.025,EN_","_DFN_",",.04)

 +74                       if (+$ORDER(^DPT(DFN,.025,EN)))

                               WRITE !

                       End DoDot:2

               End DoDot:1

 +75       IF SXOD'=""

               WRITE !,"Sexual Orientation Free Text: ",SXOD

 +76      ;PRONOUN

 +77       IF $ORDER(^DPT(DFN,.2406,0))'=""

               WRITE !,"Pronoun: "

               Begin DoDot:1

 +78               SET EN=0

FOR

                       SET EN=$ORDER(^DPT(DFN,.2406,EN))

                       if 'EN

                           QUIT

                       Begin DoDot:2

 +79                       SET PRN=$GET(^DPT(DFN,.2406,EN,0))

 +80                       WRITE ?20,$PIECE($GET(^DG(47.78,PRN,0)),"^")

                           if (+$ORDER(^DPT(DFN,.2406,EN)))

                               WRITE !

                       End DoDot:2

               End DoDot:1

 +81       IF PRND'=""

               WRITE !,"Pronoun Description: ",PRND

 +82      ;**876 - MVI_3432 (cml)  **902 - MVI_4730 (cml) MOVED HERE IN 1059

           IF SIGEN'=""

               WRITE !,"Self-Identified Gender Identity: ",SIGEN

 +83       WRITE !,"Claim #      :  ",CLAIM

 +84       WRITE !,"Date of Birth:  ",DOB

 +85      ;**926 - Story 323009 (ckn): DOD fields

 +86       IF DOD]""

               Begin DoDot:1

 +87               WRITE !,"Date of Death:  ",DOD

 +88               IF DODENTBY]""

                       WRITE !,?15,"Entered By: ",?42,DODENTBY

 +89               IF DODSRC]""

                       WRITE !,?15,"Source of Notification: ",?42,DODSRC

 +90               IF DODLUPD]""

                       WRITE !,?15,"Last Updated: ",?42,DODLUPD

 +91               IF DODLEBY]""

                       WRITE !,?15,"Last Edited By: ",?42,DODLEBY

 +92               IF DODD]""

                       WRITE !,?15,"Supporting Document Type: ",?42,DODD

 +93               IF DODOPT]""

                       WRITE !,?15,"Option Used: ",?42,DODOPT

               End DoDot:1

 +94      ;**707

           IF MBI]""

               WRITE !,"Multiple Birth Indicator: ",MBI

 +95      ;**837, MVI_883

           IF TIN]""

               WRITE !,"DoD Temporary ID Number : ",TIN

 +96      ;**837, MVI_883

           IF FIN]""

               WRITE !,"DoD Foreign ID Number   : ",FIN

 +97      ;**1059 VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121

           WRITE !,"Correspondence Address:"

           IF BAI'=""

               WRITE " (Bad Address Indicator: ",BAI,")"

 +98       IF STR1'=""

               WRITE !?9,STR1

 +99       IF STR2'=""

               WRITE !?9,STR2

 +100      IF STR3'=""

               WRITE !?9,STR3

 +101     ;USA Address  **863 - MVI_1902 (ptd)

           IF COUNTRY=""!(CCODE="USA")

               Begin DoDot:1

 +102              IF CTY]""

                       WRITE !?9,$EXTRACT(CTY,1,20)_", "_$GET(ST)_" "_$GET(ZIP)

               End DoDot:1

 +103     ;Foreign Address

           IF COUNTRY]""

               IF CCODE'="USA"

                   Begin DoDot:1

 +104                  IF CTY]""!(PROVINCE]"")!(POSTCODE]"")

                           Begin DoDot:2

 +105                          IF PROVINCE]""

                                   WRITE !?9,CTY_", "_PROVINCE_" ("_CNAME_")  "_POSTCODE

 +106                          IF PROVINCE=""

                                   WRITE !?9,CTY_", "_"("_CNAME_")  "_POSTCODE

                           End DoDot:2

                   End DoDot:1

 +107      WRITE !,"Residential Address: "

 +108      IF REST1'=""

               WRITE !?9,REST1

 +109      IF REST2'=""

               WRITE !?9,REST2

 +110      IF REST3'=""

               WRITE !?9,REST3

 +111      IF $GET(RESCN)=""!($GET(RCCODE)="USA")

               IF RESCTY]""

                   WRITE !?9,$EXTRACT(RESCTY,1,20)_", "_$GET(RESST)_" "_$GET(RESZP)

 +112     ;Foreign Address

           IF RESCN'=""

               IF $GET(RCCODE)'="USA"

                   Begin DoDot:1

 +113                  IF RESCTY]""!(RESP]"")!(RESPC]"")

                           Begin DoDot:2

 +114                          IF RESP]""

                                   WRITE !?9,RESCTY_", "_RESP_" ("_RCNAME_")  "_RESPC

 +115                          IF RESP=""

                                   WRITE !?9,RESCTY_", "_"("_RCNAME_")  "_RESPC

                           End DoDot:2

                   End DoDot:1

 +116      IF PHN'=""

               WRITE !,"Phone #: ",PHN

 +117     ;**1071 Story 13802 (jfw) - Retrieve/Display WorkPhone (.132) and CellPhone (.134)

 +118      IF WPHN'=""

               WRITE !,"Work  #: ",WPHN

 +119      IF CPHN'=""

               WRITE !,"Cell  #: ",CPHN

 +120      IF $GET(IOSL)<30&($EXTRACT(IOST,1,2)="C-")

               Begin DoDot:1

 +121              IF $Y>23

                       Begin DoDot:2

 +122                      SET DIR(0)="E"

                           Begin DoDot:3

 +123                          SET SS=22-$Y

                               FOR JJ=1:1:SS

                                   WRITE !

                           End DoDot:3

                           DO ^DIR

                           KILL DIR

                           IF 'Y

                               SET QFLG=1

 +124                      SET $Y=0

                       End DoDot:2

               End DoDot:1

 +125      IF QFLG=1

               GOTO QUIT

 +126     ;

TF        ;List Treating Facilities for this patient

 +1        DO TFHDR

 +2        KILL TFARR

 +3        SET TF=0

FOR

               SET TF=$ORDER(^DGCN(391.91,"APAT",DFN,TF))

               if 'TF

                   QUIT

               Begin DoDot:1

 +4                SET TFIEN=$ORDER(^DGCN(391.91,"APAT",DFN,TF,0))

 +5                SET DIC="^DGCN(391.91,"

                   SET DR=".02;.03;.07"

                   SET DA=TFIEN

                   SET DIQ(0)="EI"

                   SET DIQ="TFDATA"

 +6                DO EN^DIQ1

                   KILL DIC,DA,DR,DIQ

 +7                SET INST=""

                   SET STATION=""

 +8                SET INST=$GET(TFDATA(391.91,TFIEN,.02,"I"))

 +9                IF INST'=""

                       Begin DoDot:2

 +10                       SET DIC=4

                           SET DR="99"

                           SET DA=INST

                           SET DIQ(0)="E"

                           SET DIQ="STA"

 +11                       DO EN^DIQ1

                           KILL DIC,DA,DR,DIQ

 +12                       SET STATION=$GET(STA(4,INST,99,"E"))

                       End DoDot:2

 +13               SET TFNM=$GET(TFDATA(391.91,TFIEN,.02,"E"))

 +14               SET LSTDT=$GET(TFDATA(391.91,TFIEN,.03,"I"))

                   if LSTDT=""

                       SET LSTDT="none found"

 +15               SET LSTSORT=9999999

 +16               IF +LSTDT

                       SET LSTSORT=9999999-LSTDT

                       SET LSTDT=$$FMTE^XLFDT($EXTRACT(LSTDT,1,12))

 +17               SET REACODE=$GET(TFDATA(391.91,TFIEN,.07,"E"))

                   SET REASON="none found"

 +18               IF REACODE'=""

                       Begin DoDot:2

 +19                       SET DIC="^VAT(391.72,"

                           SET DIC(0)="Z"

                           SET X=REACODE

                           DO ^DIC

                           KILL DIC,X

 +20                       SET REASON=$PIECE($GET(Y(0)),"^",4)

                       End DoDot:2

 +21               SET TFARR(LSTSORT,TFNM)=TFIEN_"^"_REASON_"^"_$GET(STATION)_"^"_LSTDT

               End DoDot:1

 +22       IF '$DATA(TFARR)

               WRITE !,"No Treating Facilities found."

               GOTO SUB

 +23       SET LSTSORT=0

FOR

               SET LSTSORT=$ORDER(TFARR(LSTSORT))

               if 'LSTSORT

                   QUIT

               Begin DoDot:1

 +24               SET TFNM=""

FOR

                       SET TFNM=$ORDER(TFARR(LSTSORT,TFNM))

                       if TFNM=""

                           QUIT

                       Begin DoDot:2

 +25                       SET REASON=$PIECE(TFARR(LSTSORT,TFNM),"^",2)

 +26                       SET STATION=$PIECE(TFARR(LSTSORT,TFNM),"^",3)

 +27                       SET LSTDT=$PIECE(TFARR(LSTSORT,TFNM),"^",4)

 +28                       IF $Y+3>IOSL&($EXTRACT(IOST,1,2)="C-")

                               Begin DoDot:3

 +29                               SET LNQ=22

                                   DO SS

                                   if QFLG

                                       QUIT

 +30                               WRITE @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2

                                   DO TFHDR

                               End DoDot:3

                               if QFLG

                                   QUIT

 +31                       WRITE !,$EXTRACT(TFNM,1,20),?22,$GET(STATION),?32,LSTDT,?54,REASON

                       End DoDot:2

                       if QFLG

                           QUIT

               End DoDot:1

               if QFLG

                   GOTO QUIT

SUB       ;removed listing of subscribers for RG*1.0*23

HIS       ;find ICN history

 +1        IF '$ORDER(^DPT(DFN,"MPIFHIS",0))

               GOTO CONT

 +2       ;

 +3        IF $Y+4>IOSL&($EXTRACT(IOST,1,2)="C-")

               Begin DoDot:1

 +4                SET LNQ=22

                   DO SS

                   if QFLG

                       QUIT

 +5                WRITE @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2

               End DoDot:1

               if QFLG

                   GOTO QUIT

 +6        DO ICNHDR

 +7        SET HIS=0

FOR

               SET HIS=$ORDER(^DPT(DFN,"MPIFHIS",HIS))

               if 'HIS

                   QUIT

               Begin DoDot:1

 +8       ;**863 - MVI_2351 (ptd)

                   SET DIC=2

                   SET DR="992"

                   SET DR(2.0992)=".01;1;3"

                   SET DA=DFN

                   SET DA(2.0992)=HIS

 +9                SET DIQ(0)="E"

                   SET DIQ="HISNODE"

 +10               DO EN^DIQ1

                   KILL DIC,DA,DR,DIQ

 +11               SET HISICN=$GET(HISNODE(2.0992,HIS,.01,"E"))

 +12      ;**863 - MVI_2351 (ptd) history checksum

                   SET HISCHK=$GET(HISNODE(2.0992,HIS,1,"E"))

 +13      ;**863 - MVI_2351 (ptd) History full ICN

                   SET HFULLICN=HISICN_$SELECT(HISCHK]"":"V"_HISCHK,1:"")

 +14               SET HISDT=$GET(HISNODE(2.0992,HIS,3,"E"))

 +15               IF $Y+3>IOSL&($EXTRACT(IOST,1,2)="C-")

                       Begin DoDot:2

 +16                       SET LNQ=22

                           DO SS

                           if QFLG

                               QUIT

 +17                       WRITE @IOF,!,"MPI/PD data for: ",NAME,"  (DFN #",DFN,")",!,LN2

                           DO ICNHDR

                       End DoDot:2

                       if QFLG

                           QUIT

 +18      ;**863 - MVI_2351 (ptd)

                   WRITE !,HFULLICN

                   IF HISDT]""

                       WRITE "  - changed ",HISDT

               End DoDot:1

               if QFLG

                   GOTO QUIT

 +19      ;

CONT      ;Continue to VAFCPDT2 for extended data

 +1       ;D CMORHIS^VAFCPDT2  ;CMOR History removed, called changed to EXT^VAFCPDT2  **837, MVI_918

 +2        DO EXT^VAFCPDT2

DONE      ;

 +1        IF QFLG

               GOTO QUIT

 +2        IF ($EXTRACT(IOST,1,2)="C-")

               SET LNQ=24

               DO SS

 +3       ;

QUIT      ;

 +1        KILL %,CMOR,DIC,DIR,DIRUT,DNODE,GOT,HDT,HFULLICN,HIS,HISCHK,HISDT,HISICN,JJ,LIEN

 +2        KILL LINST,LN,LSTDT,MNODE,REACODE,REASON,SCN,SCORE,SITE,SITEIEN,SITENAM,SITENUM

 +3        KILL SS,SUBN,SUBARR,TERM,TERMDT,TF,TFARR,TFDATA,TFIEN,TFNM,Y,D,CHG,CHGNODE

 +4        KILL HISNODE,DIFF,INST,RGDFN,SCRDT,STATION,STA,LN2,NAME,LSTSORT,LNQ,QFLG,MBI

 +5        QUIT

TFHDR     ;

 +1        WRITE !!,"Treating Facilities:",?22,"Station:",?32,"DT Last Treated",?54,"Event Reason"

 +2        WRITE !,"--------------------",?22,"--------",?32,"---------------",?54,"------------"

 +3        QUIT

ICNHDR     WRITE !!,"ICN History:",!,"------------"

 +1        QUIT

 +2       ;

SS         SET DIR(0)="E"

           Begin DoDot:1

 +1            SET SS=LNQ-$Y

               FOR JJ=1:1:SS

                   WRITE !

           End DoDot:1

           DO ^DIR

           KILL DIR

           IF 'Y

               SET QFLG=1

 +2        QUIT

VAFCPDAT.m