VAFCPDT2 ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 12/3/04 3:50pm
;;5.3;Registration;**414,505,627,697,1015**;Aug 13, 1993;Build 21
;Reference to ^MPIF(984.9,"C" supported by IA #3298
;
CMORHIS ;Find CMOR History
I '$O(^DPT(DFN,"MPICMOR",0)) G CMORCHG
I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
.S LNQ=22 D SS^VAFCPDAT Q:QFLG
.W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
D CHISHDR
S HIS=0 F S HIS=$O(^DPT(DFN,"MPICMOR",HIS)) Q:'HIS D Q:QFLG
.S DIC=2,DR="993",DR(2.0993)=".01;3",DA=DFN,DA(2.0993)=HIS
.S DIQ(0)="E",DIQ="CMORNODE"
.D EN^DIQ1 K DIC,DR,DA,DIQ
.S HISCMOR=$G(CMORNODE(2.0993,HIS,.01,"E"))
.I +HISCMOR S HISCMOR=$$GET1^DIQ(4,HISCMOR,.01)
.S CHGDT=$G(CMORNODE(2.0993,HIS,3,"E"))
.I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
..S LNQ=22 D SS^VAFCPDAT Q:QFLG
..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CHISHDR
.W !,$P(CHGDT,"@"),?12," - CMOR changed from ",HISCMOR
;
CMORCHG ;Find CMOR change request
I '$O(^MPIF(984.9,"C",DFN,0)) G EXT
I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
.S LNQ=22 D SS^VAFCPDAT Q:QFLG
.W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
D CCHGHDR
S CHG=0 F S CHG=$O(^MPIF(984.9,"C",DFN,CHG)) Q:'CHG D Q:QFLG
.S DIC=984.9,DA=CHG,DR=".01;.03;.06;.07;.08;1.03",DIQ="CHGNODE"
.S DIQ(0)="EI" D EN^DIQ1 K DIC,DA,DR,DIQ
.S CHGNUM=$G(CHGNODE(984.9,CHG,.01,"E"))
.S CHGDT=$G(CHGNODE(984.9,CHG,.03,"E"))
.S TMSG=$G(CHGNODE(984.9,CHG,.08,"E"))
.S TREQ=$G(CHGNODE(984.9,CHG,1.03,"E"))
.S SITE=$G(CHGNODE(984.9,CHG,.07,"E"))
.S STATUS=$G(CHGNODE(984.9,CHG,.06,"E"))
.I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG
..S LNQ=22 D SS^VAFCPDAT Q:QFLG
..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CCHGHDR
.W !,"REQUEST #",CHGNUM," - ",TMSG," ",CHGDT
.W !?4,"Type of Request: ",TREQ," ",SITE
.W !?4,"Status : ",STATUS,!
;
EXT ;Extended patient demographic data
I $E(IOST,1,2)="C-" D Q:QFLG
.S LNQ=22 D SS^VAFCPDAT Q:QFLG
.W @IOF
I QFLG=1 G QUIT^VAFCPDAT
W !!,"Additional DPT Data for: ",NAME," (DFN #",DFN,")",!,LN2
S DA=DFN,DIC=2,DIQ="XDATA",DIQ(0)="EI"
S DR=".05;.08;.092;.093;.219;.2401;.2402;.2403;.211;.302;.323;.341;.331;.361;1901;.325;.328;.326;.327;.097;.525"
N COB,SOB,FNM,MNM,MMNM,NOK,NOKN,DESIG,EMER,ELIG,VET,SRVBR,SRVNUM,SRVEDT,SRVSDT,SRVCPCT,POSRVC,FILEDT,MARS,RELP,POW
D EN^DIQ1 K DIC,DA,DR,DIQ
S COB=$G(XDATA(2,DFN,.092,"E")),SOB=$G(XDATA(2,DFN,.093,"E"))
S FILEDT=$G(XDATA(2,DFN,.097,"E")),FNM=$G(XDATA(2,DFN,.2401,"E"))
S MNM=$G(XDATA(2,DFN,.2402,"E")),MMNM=$G(XDATA(2,DFN,.2403,"E"))
S NOK=$G(XDATA(2,DFN,.211,"E")),DESIG=$G(XDATA(2,DFN,.341,"E"))
S EMER=$G(XDATA(2,DFN,.331,"E"))
S ELIG=$G(XDATA(2,DFN,.361,"E")),VET=$G(XDATA(2,DFN,1901,"E"))
S SRVBR=$G(XDATA(2,DFN,.325,"E")),SRVNUM=$G(XDATA(2,DFN,.328,"E"))
S SRVEDT=$G(XDATA(2,DFN,.326,"E")),SRVSDT=$G(XDATA(2,DFN,.327,"E"))
S MARS=$G(XDATA(2,DFN,.05,"E")),RELP=$G(XDATA(2,DFN,.08,"E"))
S POSRVC=$G(XDATA(2,DFN,.323,"E")),SRVCPCT=$G(XDATA(2,DFN,.302,"E"))
S NOKN=$G(XDATA(2,DFN,.219,"E")),POW=$G(XDATA(2,DFN,.525,"E"))
;
W !,"PLACE OF BIRTH [CITY]",?31,": ",COB
W !,"PLACE OF BIRTH [STATE]",?31,": ",SOB
W !,"FATHER'S NAME",?31,": ",FNM
W !,"MOTHER'S NAME",?31,": ",MNM
W !,"MOTHER'S MAIDEN NAME",?31,": ",MMNM
W !,"NAME OF PRIMARY NEXT OF KIN",?31,": ",NOK
W !,"NEXT OF KIN PHONE NUMBER",?31,": ",NOKN
W !,"NAME OF DESIGNEE",?31,": ",DESIG
W !,"EMERGENCY NAME",?31,": ",EMER
W !,"MARITAL STATUS",?31,": ",MARS
W !,"RELIGIOUS PREFERENCE",?31,": ",RELP
W !,"PRIMARY ELIGIBILITY CODE",?31,": ",ELIG
W !,"VETERAN (Y/N)?",?31,": ",VET
W !,"SERVICE BRANCH [LAST]",?31,": ",SRVBR
W !,"SERVICE NUMBER [LAST]",?31,": ",SRVNUM
W !,"SERVICE CONNECTED PERCENT",?31,": ",SRVCPCT
W !,"SERVICE ENTRY DATE [LAST]",?31,": ",SRVEDT
W !,"SERVICE SEPARATION DATE [LAST]",?31,": ",SRVSDT
W !,"PERIOD OF SERVICE",?31,": ",POSRVC
W !,"POW STATUS INDICATED?",?31,": ",POW
W !,"DATE ENTERED IN PATIENT FILE",?31,": ",FILEDT
;
D DEM^VADPT
;ETHNICITY info
I $G(VADM(11,1)) W !,"ETHNICITY INFORMATION",?31,": ",$P(VADM(11,1),"^",2)
;
;RACE multiple
I $O(VADM(12,0)) D
.W !,"RACE INFORMATION (multiple):"
.S RACEMUL=0 F S RACEMUL=$O(VADM(12,RACEMUL)) Q:'RACEMUL W !?3,$P(VADM(12,RACEMUL),"^",2)
;
;ALIAS multiple
I $O(^DPT(DFN,.01,0)) D
.W !,"ALIAS (multiple):"
.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)
;
K ALIAS,XDATA,CHG,CHGNUM,CHGDT,TMSG,TREQ,SITE,STATUS,HIS,HISCMOR,CMORNODE,CHGNODE,RACEMUL,VADM
Q
;
CHISHDR W !!,"CMOR History:",!,"--------------"
Q
CCHGHDR W !!,"CMOR Change Request History:",!,"----------------------------"
Q
VAFCPDT2 ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ; 12/3/04 3:50pm
+1 ;;5.3;Registration;**414,505,627,697,1015**;Aug 13, 1993;Build 21
+2 ;Reference to ^MPIF(984.9,"C" supported by IA #3298
+3 ;
CMORHIS ;Find CMOR History
+1 IF '$ORDER(^DPT(DFN,"MPICMOR",0))
GOTO CMORCHG
+2 IF $Y+4>IOSL&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:1
+3 SET LNQ=22
DO SS^VAFCPDAT
IF QFLG
QUIT
+4 WRITE @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
End DoDot:1
IF QFLG
QUIT
+5 DO CHISHDR
+6 SET HIS=0
FOR
SET HIS=$ORDER(^DPT(DFN,"MPICMOR",HIS))
IF 'HIS
QUIT
Begin DoDot:1
+7 SET DIC=2
SET DR="993"
SET DR(2.0993)=".01;3"
SET DA=DFN
SET DA(2.0993)=HIS
+8 SET DIQ(0)="E"
SET DIQ="CMORNODE"
+9 DO EN^DIQ1
KILL DIC,DR,DA,DIQ
+10 SET HISCMOR=$GET(CMORNODE(2.0993,HIS,.01,"E"))
+11 IF +HISCMOR
SET HISCMOR=$$GET1^DIQ(4,HISCMOR,.01)
+12 SET CHGDT=$GET(CMORNODE(2.0993,HIS,3,"E"))
+13 IF $Y+3>IOSL&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:2
+14 SET LNQ=22
DO SS^VAFCPDAT
IF QFLG
QUIT
+15 WRITE @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
DO CHISHDR
End DoDot:2
IF QFLG
QUIT
+16 WRITE !,$PIECE(CHGDT,"@"),?12," - CMOR changed from ",HISCMOR
End DoDot:1
IF QFLG
QUIT
+17 ;
CMORCHG ;Find CMOR change request
+1 IF '$ORDER(^MPIF(984.9,"C",DFN,0))
GOTO EXT
+2 IF $Y+4>IOSL&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:1
+3 SET LNQ=22
DO SS^VAFCPDAT
IF QFLG
QUIT
+4 WRITE @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
End DoDot:1
IF QFLG
QUIT
+5 DO CCHGHDR
+6 SET CHG=0
FOR
SET CHG=$ORDER(^MPIF(984.9,"C",DFN,CHG))
IF 'CHG
QUIT
Begin DoDot:1
+7 SET DIC=984.9
SET DA=CHG
SET DR=".01;.03;.06;.07;.08;1.03"
SET DIQ="CHGNODE"
+8 SET DIQ(0)="EI"
DO EN^DIQ1
KILL DIC,DA,DR,DIQ
+9 SET CHGNUM=$GET(CHGNODE(984.9,CHG,.01,"E"))
+10 SET CHGDT=$GET(CHGNODE(984.9,CHG,.03,"E"))
+11 SET TMSG=$GET(CHGNODE(984.9,CHG,.08,"E"))
+12 SET TREQ=$GET(CHGNODE(984.9,CHG,1.03,"E"))
+13 SET SITE=$GET(CHGNODE(984.9,CHG,.07,"E"))
+14 SET STATUS=$GET(CHGNODE(984.9,CHG,.06,"E"))
+15 IF $Y+4>IOSL&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:2
+16 SET LNQ=22
DO SS^VAFCPDAT
IF QFLG
QUIT
+17 WRITE @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
DO CCHGHDR
End DoDot:2
IF QFLG
QUIT
+18 WRITE !,"REQUEST #",CHGNUM," - ",TMSG," ",CHGDT
+19 WRITE !?4,"Type of Request: ",TREQ," ",SITE
+20 WRITE !?4,"Status : ",STATUS,!
End DoDot:1
IF QFLG
QUIT
+21 ;
EXT ;Extended patient demographic data
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 SET LNQ=22
DO SS^VAFCPDAT
IF QFLG
QUIT
+3 WRITE @IOF
End DoDot:1
IF QFLG
QUIT
+4 IF QFLG=1
GOTO QUIT^VAFCPDAT
+5 WRITE !!,"Additional DPT Data for: ",NAME," (DFN #",DFN,")",!,LN2
+6 SET DA=DFN
SET DIC=2
SET DIQ="XDATA"
SET DIQ(0)="EI"
+7 SET DR=".05;.08;.092;.093;.219;.2401;.2402;.2403;.211;.302;.323;.341;.331;.361;1901;.325;.328;.326;.327;.097;.525"
+8 NEW COB,SOB,FNM,MNM,MMNM,NOK,NOKN,DESIG,EMER,ELIG,VET,SRVBR,SRVNUM,SRVEDT,SRVSDT,SRVCPCT,POSRVC,FILEDT,MARS,RELP,POW
+9 DO EN^DIQ1
KILL DIC,DA,DR,DIQ
+10 SET COB=$GET(XDATA(2,DFN,.092,"E"))
SET SOB=$GET(XDATA(2,DFN,.093,"E"))
+11 SET FILEDT=$GET(XDATA(2,DFN,.097,"E"))
SET FNM=$GET(XDATA(2,DFN,.2401,"E"))
+12 SET MNM=$GET(XDATA(2,DFN,.2402,"E"))
SET MMNM=$GET(XDATA(2,DFN,.2403,"E"))
+13 SET NOK=$GET(XDATA(2,DFN,.211,"E"))
SET DESIG=$GET(XDATA(2,DFN,.341,"E"))
+14 SET EMER=$GET(XDATA(2,DFN,.331,"E"))
+15 SET ELIG=$GET(XDATA(2,DFN,.361,"E"))
SET VET=$GET(XDATA(2,DFN,1901,"E"))
+16 SET SRVBR=$GET(XDATA(2,DFN,.325,"E"))
SET SRVNUM=$GET(XDATA(2,DFN,.328,"E"))
+17 SET SRVEDT=$GET(XDATA(2,DFN,.326,"E"))
SET SRVSDT=$GET(XDATA(2,DFN,.327,"E"))
+18 SET MARS=$GET(XDATA(2,DFN,.05,"E"))
SET RELP=$GET(XDATA(2,DFN,.08,"E"))
+19 SET POSRVC=$GET(XDATA(2,DFN,.323,"E"))
SET SRVCPCT=$GET(XDATA(2,DFN,.302,"E"))
+20 SET NOKN=$GET(XDATA(2,DFN,.219,"E"))
SET POW=$GET(XDATA(2,DFN,.525,"E"))
+21 ;
+22 WRITE !,"PLACE OF BIRTH [CITY]",?31,": ",COB
+23 WRITE !,"PLACE OF BIRTH [STATE]",?31,": ",SOB
+24 WRITE !,"FATHER'S NAME",?31,": ",FNM
+25 WRITE !,"MOTHER'S NAME",?31,": ",MNM
+26 WRITE !,"MOTHER'S MAIDEN NAME",?31,": ",MMNM
+27 WRITE !,"NAME OF PRIMARY NEXT OF KIN",?31,": ",NOK
+28 WRITE !,"NEXT OF KIN PHONE NUMBER",?31,": ",NOKN
+29 WRITE !,"NAME OF DESIGNEE",?31,": ",DESIG
+30 WRITE !,"EMERGENCY NAME",?31,": ",EMER
+31 WRITE !,"MARITAL STATUS",?31,": ",MARS
+32 WRITE !,"RELIGIOUS PREFERENCE",?31,": ",RELP
+33 WRITE !,"PRIMARY ELIGIBILITY CODE",?31,": ",ELIG
+34 WRITE !,"VETERAN (Y/N)?",?31,": ",VET
+35 WRITE !,"SERVICE BRANCH [LAST]",?31,": ",SRVBR
+36 WRITE !,"SERVICE NUMBER [LAST]",?31,": ",SRVNUM
+37 WRITE !,"SERVICE CONNECTED PERCENT",?31,": ",SRVCPCT
+38 WRITE !,"SERVICE ENTRY DATE [LAST]",?31,": ",SRVEDT
+39 WRITE !,"SERVICE SEPARATION DATE [LAST]",?31,": ",SRVSDT
+40 WRITE !,"PERIOD OF SERVICE",?31,": ",POSRVC
+41 WRITE !,"POW STATUS INDICATED?",?31,": ",POW
+42 WRITE !,"DATE ENTERED IN PATIENT FILE",?31,": ",FILEDT
+43 ;
+44 DO DEM^VADPT
+45 ;ETHNICITY info
+46 IF $GET(VADM(11,1))
WRITE !,"ETHNICITY INFORMATION",?31,": ",$PIECE(VADM(11,1),"^",2)
+47 ;
+48 ;RACE multiple
+49 IF $ORDER(VADM(12,0))
Begin DoDot:1
+50 WRITE !,"RACE INFORMATION (multiple):"
+51 SET RACEMUL=0
FOR
SET RACEMUL=$ORDER(VADM(12,RACEMUL))
IF 'RACEMUL
QUIT
WRITE !?3,$PIECE(VADM(12,RACEMUL),"^",2)
End DoDot:1
+52 ;
+53 ;ALIAS multiple
+54 IF $ORDER(^DPT(DFN,.01,0))
Begin DoDot:1
+55 WRITE !,"ALIAS (multiple):"
+56 SET ALIAS=0
FOR
SET ALIAS=$ORDER(^DPT(DFN,.01,ALIAS))
IF 'ALIAS
QUIT
WRITE !?3,$EXTRACT($PIECE(^DPT(DFN,.01,ALIAS,0),"^"),1,30),?35,"SSN: "_$PIECE($GET(^DPT(DFN,.01,ALIAS,0)),"^",2)
End DoDot:1
+57 ;
+58 KILL ALIAS,XDATA,CHG,CHGNUM,CHGDT,TMSG,TREQ,SITE,STATUS,HIS,HISCMOR,CMORNODE,CHGNODE,RACEMUL,VADM
+59 QUIT
+60 ;
CHISHDR WRITE !!,"CMOR History:",!,"--------------"
+1 QUIT
CCHGHDR WRITE !!,"CMOR Change Request History:",!,"----------------------------"
+1 QUIT
