VAFCPDAT ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ;10/24/02 13:13
;;5.3;PIMS;**333,414,474,505,707,1015,1016**;JUN 30, 2012;Build 20
;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
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;.313;.351;994;.0907;.0906;.121",DA=DFN,DIQ(0)="EI",DIQ="DNODE" ;**707,712
N NAME,SSN,DOB,SEX,CLAIM,DOD,ICN,STR1,STR2,STR3,CTY,ST,ZIP,PHN,MBI,SSNVER,PREAS,BAI ;**707,712
D EN^DIQ1 K DIC,DR,DA,DIQ
S NAME=$G(DNODE(2,DFN,.01,"E")),SSN=$G(DNODE(2,DFN,.09,"E"))
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")),DOD=$G(DNODE(2,DFN,.351,"E"))
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 PHN=$G(DNODE(2,DFN,.131,"E"))
S SSNVER=$G(DNODE(2,DFN,.0907,"E")) ;**707
S PREAS=$G(DNODE(2,DFN,.0906,"E")) ;**707
S MNODE=$$MPINODE^MPIFAPI(DFN) I +MNODE=-1 S MNODE="^^^^^"
S (ICN,CMOR,SCN,SCORE,SCRDT,DIFF)=""
S ICN=$P($G(MNODE),"^") S:ICN="" ICN="None"
S CMOR=$$GET1^DIQ(4,+$P($G(MNODE),"^",3)_",",.01) S:CMOR="" CMOR="None"
I $E(ICN,1,3)=SITENUM S GOT=0 D
. I $P($G(MNODE),"^",4)=""!('$D(^DPT("AICNL",1,DFN))) S ICN=ICN_"**"
;
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,?40,"CMOR: ",CMOR
W !,"SSN : ",SSN
I SSNVER]"" W !?9,"SSN Verification Status: ",SSNVER
I SSNVER="",PREAS]"" W !?9,"Pseudo SSN Reason: ",PREAS
I SSNVER]"",PREAS]"" W !?9,"Pseudo SSN Reason : ",PREAS
W !,"Sex : ",SEX
W !,"Claim #: ",CLAIM
W !,"Date of Birth: ",DOB
I DOD]"" W !,"Date of Death: ",DOD
I MBI]"" W !,"Multiple Birth Indicator: ",MBI ;**707
W !,"Address:" I BAI'="" W " (Bad Address Indicator: ",BAI,")"
I STR1'="" W !?9,STR1
I STR2'="" W !?9,STR2
I STR3'="" W !?9,STR3
I CTY'="" W !?9,$E(CTY,1,20)_", "_$G(ST)_" "_$G(ZIP)
I PHN'="" W !,"Phone #: ",PHN
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;3",DA=DFN,DA(2.0992)=HIS
.S DIQ(0)="E",DIQ="HISNODE"
.D EN^DIQ1 K DIC,DA,DR,DIQ
.S HISICN=$G(HISNODE(2.0992,HIS,.01,"E"))
.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 !,HISICN I HISDT]"" W " - changed ",HISDT
;
CONT ;Continue to VAFCPDT2 for CMOR data and extended data
D CMORHIS^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,HIS,HISDT,HISICN,JJ,LIEN,LINST
K 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
VAFCPDAT ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ;10/24/02 13:13
+1 ;;5.3;PIMS;**333,414,474,505,707,1015,1016**;JUN 30, 2012;Build 20
+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 SET $PIECE(LN,"=",80)=""
SET $PIECE(LN2,"=",60)=""
SET QFLG=0
+2 DO NOW^%DTC
SET HDT=$$FMTE^XLFDT($EXTRACT(%,1,12))
+3 SET SITE=$$SITE^VASITE()
SET SITENAM=$PIECE(SITE,"^",2)
SET SITENUM=$PIECE(SITE,"^",3)
SET SITEIEN=$PIECE(SITE,"^")
+4 IF +DFN<0
Begin DoDot:1
+5 IF $DATA(NOTRPC)
WRITE @IOF,!," "
+6 WRITE !,"ICN ",$GET(ICN)," does not exist at ",SITENAM,"."
+7 WRITE !,"Search date: ",HDT,!,LN
End DoDot:1
QUIT
+8 ;**707,712
SET DIC=2
SET DR=".01;.02;.03;.09;.111;.112;.113;.114;.115;.1112;.131;.313;.351;994;.0907;.0906;.121"
SET DA=DFN
SET DIQ(0)="EI"
SET DIQ="DNODE"
+9 ;**707,712
NEW NAME,SSN,DOB,SEX,CLAIM,DOD,ICN,STR1,STR2,STR3,CTY,ST,ZIP,PHN,MBI,SSNVER,PREAS,BAI
+10 DO EN^DIQ1
KILL DIC,DR,DA,DIQ
+11 SET NAME=$GET(DNODE(2,DFN,.01,"E"))
SET SSN=$GET(DNODE(2,DFN,.09,"E"))
+12 SET DOB=$$FMTE^XLFDT($GET(DNODE(2,DFN,.03,"I")))
+13 ;**707
SET MBI=$GET(DNODE(2,DFN,994,"I"))
SET MBI=$SELECT(MBI="Y":"YES",MBI="N":"NO",1:"NULL")
+14 SET SEX=$GET(DNODE(2,DFN,.02,"E"))
SET DOD=$GET(DNODE(2,DFN,.351,"E"))
+15 SET CLAIM=$GET(DNODE(2,DFN,.313,"E"))
IF CLAIM=""
SET CLAIM="None"
+16 ;**712
SET BAI=$GET(DNODE(2,DFN,.121,"E"))
+17 SET STR1=$GET(DNODE(2,DFN,.111,"E"))
SET STR2=$GET(DNODE(2,DFN,.112,"E"))
SET STR3=$GET(DNODE(2,DFN,.113,"E"))
+18 SET CTY=$GET(DNODE(2,DFN,.114,"E"))
SET ST=$GET(DNODE(2,DFN,.115,"E"))
SET ZIP=$GET(DNODE(2,DFN,.1112,"E"))
+19 SET PHN=$GET(DNODE(2,DFN,.131,"E"))
+20 ;**707
SET SSNVER=$GET(DNODE(2,DFN,.0907,"E"))
+21 ;**707
SET PREAS=$GET(DNODE(2,DFN,.0906,"E"))
+22 SET MNODE=$$MPINODE^MPIFAPI(DFN)
IF +MNODE=-1
SET MNODE="^^^^^"
+23 SET (ICN,CMOR,SCN,SCORE,SCRDT,DIFF)=""
+24 SET ICN=$PIECE($GET(MNODE),"^")
IF ICN=""
SET ICN="None"
+25 SET CMOR=$$GET1^DIQ(4,+$PIECE($GET(MNODE),"^",3)_",",.01)
IF CMOR=""
SET CMOR="None"
+26 IF $EXTRACT(ICN,1,3)=SITENUM
SET GOT=0
Begin DoDot:1
+27 IF $PIECE($GET(MNODE),"^",4)=""!('$DATA(^DPT("AICNL",1,DFN)))
SET ICN=ICN_"**"
End DoDot:1
+28 ;
+29 IF $DATA(NOTRPC)
WRITE @IOF,!
+30 WRITE !,"MPI/PD Data for: ",NAME," (DFN #",DFN,")"
+31 ; check for patient sensitivity and user security
+32 NEW RESULT,RGSENS,SENSTV,DA,DR,DIC,DIQ,VAFCSEN
+33 DO PTSEC^DGSEC4(.RESULT,DFN,0,"MPI/PD Patient Inquiry^MPI/PD Patient Inquiry")
+34 IF RESULT(1)=-1
WRITE !!,"Access denied: Required parameters not defined"
GOTO QUIT
+35 IF RESULT(1)>0
WRITE ?50,"***PATIENT MARKED SENSITIVE***"
+36 IF RESULT(1)=3
WRITE !!,"Access not allowed on your own PATIENT (#2) file entry"
GOTO QUIT
+37 IF RESULT(1)=4
WRITE !!,"Access denied: Your SSN is not defined"
GOTO QUIT
+38 IF RESULT(1)<3
Begin DoDot:1
+39 ;IA #3027
IF RESULT(1)=1
DO NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",2)
+40 ;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
+41 WRITE !,"Printed ",HDT," at ",SITENAM,!,LN
+42 SET $Y=$Y+1
+43 ;next 7 lines modified for **707
+44 WRITE !,"ICN : ",ICN,?40,"CMOR: ",CMOR
+45 WRITE !,"SSN : ",SSN
+46 IF SSNVER]""
WRITE !?9,"SSN Verification Status: ",SSNVER
+47 IF SSNVER=""
IF PREAS]""
WRITE !?9,"Pseudo SSN Reason: ",PREAS
+48 IF SSNVER]""
IF PREAS]""
WRITE !?9,"Pseudo SSN Reason : ",PREAS
+49 WRITE !,"Sex : ",SEX
+50 WRITE !,"Claim #: ",CLAIM
+51 WRITE !,"Date of Birth: ",DOB
+52 IF DOD]""
WRITE !,"Date of Death: ",DOD
+53 ;**707
IF MBI]""
WRITE !,"Multiple Birth Indicator: ",MBI
+54 WRITE !,"Address:"
IF BAI'=""
WRITE " (Bad Address Indicator: ",BAI,")"
+55 IF STR1'=""
WRITE !?9,STR1
+56 IF STR2'=""
WRITE !?9,STR2
+57 IF STR3'=""
WRITE !?9,STR3
+58 IF CTY'=""
WRITE !?9,$EXTRACT(CTY,1,20)_", "_$GET(ST)_" "_$GET(ZIP)
+59 IF PHN'=""
WRITE !,"Phone #: ",PHN
+60 IF $GET(IOSL)<30&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:1
+61 IF $Y>23
Begin DoDot:2
+62 SET DIR(0)="E"
Begin DoDot:3
+63 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:3
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
+64 SET $Y=0
End DoDot:2
End DoDot:1
+65 IF QFLG=1
GOTO QUIT
+66 ;
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 SET DIC=2
SET DR="992"
SET DR(2.0992)=".01;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 SET HISDT=$GET(HISNODE(2.0992,HIS,3,"E"))
+13 IF $Y+3>IOSL&($EXTRACT(IOST,1,2)="C-")
Begin DoDot:2
+14 SET LNQ=22
DO SS
IF QFLG
QUIT
+15 WRITE @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2
DO ICNHDR
End DoDot:2
IF QFLG
QUIT
+16 WRITE !,HISICN
IF HISDT]""
WRITE " - changed ",HISDT
End DoDot:1
IF QFLG
GOTO QUIT
+17 ;
CONT ;Continue to VAFCPDT2 for CMOR data and extended data
+1 DO CMORHIS^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,HIS,HISDT,HISICN,JJ,LIEN,LINST
+2 KILL 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
