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
Q
;
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
Q
TFHDR ;
W !!,"Treating Facilities:",?22,"Station:",?32,"DT Last Treated",?54,"Event Reason"
W !,"--------------------",?22,"--------",?32,"---------------",?54,"------------"
Q
ICNHDR W !!,"ICN History:",!,"------------"
Q
;
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 !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCPDAT 11988 printed Dec 13, 2024@03:02:07 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
