source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPDT2.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1VAFCPDT2 ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 12/3/04 3:50pm
2 ;;5.3;Registration;**414,505,627,697**;Aug 13, 1993
3 ;Reference to ^MPIF(984.9,"C" supported by IA #3298
4 ;
5CMORHIS ;Find CMOR History
6 I '$O(^DPT(DFN,"MPICMOR",0)) G CMORCHG
7 I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
8 .S LNQ=22 D SS^VAFCPDAT Q:QFLG
9 .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
10 D CHISHDR
11 S HIS=0 F S HIS=$O(^DPT(DFN,"MPICMOR",HIS)) Q:'HIS D Q:QFLG
12 .S DIC=2,DR="993",DR(2.0993)=".01;3",DA=DFN,DA(2.0993)=HIS
13 .S DIQ(0)="E",DIQ="CMORNODE"
14 .D EN^DIQ1 K DIC,DR,DA,DIQ
15 .S HISCMOR=$G(CMORNODE(2.0993,HIS,.01,"E"))
16 .I +HISCMOR S HISCMOR=$$GET1^DIQ(4,HISCMOR,.01)
17 .S CHGDT=$G(CMORNODE(2.0993,HIS,3,"E"))
18 .I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
19 ..S LNQ=22 D SS^VAFCPDAT Q:QFLG
20 ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CHISHDR
21 .W !,$P(CHGDT,"@"),?12," - CMOR changed from ",HISCMOR
22 ;
23CMORCHG ;Find CMOR change request
24 I '$O(^MPIF(984.9,"C",DFN,0)) G EXT
25 I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
26 .S LNQ=22 D SS^VAFCPDAT Q:QFLG
27 .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
28 D CCHGHDR
29 S CHG=0 F S CHG=$O(^MPIF(984.9,"C",DFN,CHG)) Q:'CHG D Q:QFLG
30 .S DIC=984.9,DA=CHG,DR=".01;.03;.06;.07;.08;1.03",DIQ="CHGNODE"
31 .S DIQ(0)="EI" D EN^DIQ1 K DIC,DA,DR,DIQ
32 .S CHGNUM=$G(CHGNODE(984.9,CHG,.01,"E"))
33 .S CHGDT=$G(CHGNODE(984.9,CHG,.03,"E"))
34 .S TMSG=$G(CHGNODE(984.9,CHG,.08,"E"))
35 .S TREQ=$G(CHGNODE(984.9,CHG,1.03,"E"))
36 .S SITE=$G(CHGNODE(984.9,CHG,.07,"E"))
37 .S STATUS=$G(CHGNODE(984.9,CHG,.06,"E"))
38 .I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
39 ..S LNQ=22 D SS^VAFCPDAT Q:QFLG
40 ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CCHGHDR
41 .W !,"REQUEST #",CHGNUM," - ",TMSG," ",CHGDT
42 .W !?4,"Type of Request: ",TREQ," ",SITE
43 .W !?4,"Status : ",STATUS,!
44 ;
45EXT ;Extended patient demographic data
46 I $E(IOST,1,2)="C-" D Q:QFLG
47 .S LNQ=22 D SS^VAFCPDAT Q:QFLG
48 .W @IOF
49 I QFLG=1 G QUIT^VAFCPDAT
50 W !!,"Additional DPT Data for: ",NAME," (DFN #",DFN,")",!,LN2
51 S DA=DFN,DIC=2,DIQ="XDATA",DIQ(0)="EI"
52 S DR=".05;.08;.092;.093;.219;.2401;.2402;.2403;.211;.302;.323;.341;.331;.361;1901;.325;.328;.326;.327;.097;.525"
53 N COB,SOB,FNM,MNM,MMNM,NOK,NOKN,DESIG,EMER,ELIG,VET,SRVBR,SRVNUM,SRVEDT,SRVSDT,SRVCPCT,POSRVC,FILEDT,MARS,RELP,POW
54 D EN^DIQ1 K DIC,DA,DR,DIQ
55 S COB=$G(XDATA(2,DFN,.092,"E")),SOB=$G(XDATA(2,DFN,.093,"E"))
56 S FILEDT=$G(XDATA(2,DFN,.097,"E")),FNM=$G(XDATA(2,DFN,.2401,"E"))
57 S MNM=$G(XDATA(2,DFN,.2402,"E")),MMNM=$G(XDATA(2,DFN,.2403,"E"))
58 S NOK=$G(XDATA(2,DFN,.211,"E")),DESIG=$G(XDATA(2,DFN,.341,"E"))
59 S EMER=$G(XDATA(2,DFN,.331,"E"))
60 S ELIG=$G(XDATA(2,DFN,.361,"E")),VET=$G(XDATA(2,DFN,1901,"E"))
61 S SRVBR=$G(XDATA(2,DFN,.325,"E")),SRVNUM=$G(XDATA(2,DFN,.328,"E"))
62 S SRVEDT=$G(XDATA(2,DFN,.326,"E")),SRVSDT=$G(XDATA(2,DFN,.327,"E"))
63 S MARS=$G(XDATA(2,DFN,.05,"E")),RELP=$G(XDATA(2,DFN,.08,"E"))
64 S POSRVC=$G(XDATA(2,DFN,.323,"E")),SRVCPCT=$G(XDATA(2,DFN,.302,"E"))
65 S NOKN=$G(XDATA(2,DFN,.219,"E")),POW=$G(XDATA(2,DFN,.525,"E"))
66 ;
67 W !,"PLACE OF BIRTH [CITY]",?31,": ",COB
68 W !,"PLACE OF BIRTH [STATE]",?31,": ",SOB
69 W !,"FATHER'S NAME",?31,": ",FNM
70 W !,"MOTHER'S NAME",?31,": ",MNM
71 W !,"MOTHER'S MAIDEN NAME",?31,": ",MMNM
72 W !,"NAME OF PRIMARY NEXT OF KIN",?31,": ",NOK
73 W !,"NEXT OF KIN PHONE NUMBER",?31,": ",NOKN
74 W !,"NAME OF DESIGNEE",?31,": ",DESIG
75 W !,"EMERGENCY NAME",?31,": ",EMER
76 W !,"MARITAL STATUS",?31,": ",MARS
77 W !,"RELIGIOUS PREFERENCE",?31,": ",RELP
78 W !,"PRIMARY ELIGIBILITY CODE",?31,": ",ELIG
79 W !,"VETERAN (Y/N)?",?31,": ",VET
80 W !,"SERVICE BRANCH [LAST]",?31,": ",SRVBR
81 W !,"SERVICE NUMBER [LAST]",?31,": ",SRVNUM
82 W !,"SERVICE CONNECTED PERCENT",?31,": ",SRVCPCT
83 W !,"SERVICE ENTRY DATE [LAST]",?31,": ",SRVEDT
84 W !,"SERVICE SEPARATION DATE [LAST]",?31,": ",SRVSDT
85 W !,"PERIOD OF SERVICE",?31,": ",POSRVC
86 W !,"POW STATUS INDICATED?",?31,": ",POW
87 W !,"DATE ENTERED IN PATIENT FILE",?31,": ",FILEDT
88 ;
89 D DEM^VADPT
90 ;ETHNICITY info
91 I $G(VADM(11,1)) W !,"ETHNICITY INFORMATION",?31,": ",$P(VADM(11,1),"^",2)
92 ;
93 ;RACE multiple
94 I $O(VADM(12,0)) D
95 .W !,"RACE INFORMATION (multiple):"
96 .S RACEMUL=0 F S RACEMUL=$O(VADM(12,RACEMUL)) Q:'RACEMUL W !?3,$P(VADM(12,RACEMUL),"^",2)
97 ;
98 ;ALIAS multiple
99 I $O(^DPT(DFN,.01,0)) D
100 .W !,"ALIAS (multiple):"
101 .S ALIAS=0 F S ALIAS=$O(^DPT(DFN,.01,ALIAS)) Q:'ALIAS W !?3,$E($P(^DPT(DFN,.01,ALIAS,0),"^"),1,30),?35,"SSN: "_$P($G(^DPT(DFN,.01,ALIAS,0)),"^",2)
102 ;
103 K ALIAS,XDATA,CHG,CHGNUM,CHGDT,TMSG,TREQ,SITE,STATUS,HIS,HISCMOR,CMORNODE,CHGNODE,RACEMUL,VADM
104 Q
105 ;
106CHISHDR W !!,"CMOR History:",!,"--------------"
107 Q
108CCHGHDR W !!,"CMOR Change Request History:",!,"----------------------------"
109 Q
Note: See TracBrowser for help on using the repository browser.