XUPSCLR ;OIFO-CS/GRR/RAM/DW/PN - New Person file Cleanup Report ; 1 Jan 2004
;;8.0;KERNEL;**309**; Jul 10, 1995
;
Q
;
DETAIL ; -- detailed report
;
N TYPE
;
S TYPE="Detail Report of"
;
D EN
;
Q
;
STATS ; -- totals only
;
N TYPE
;
S TYPE="Statistical Report of"
;
D EN
;
Q
;
EN ; -- entry point
;
N ZTDESC,ZTSAVE,ZTIO,ZTDTH,X,ZTQUEUED,ZTREQ,ZTRTN,DIR,POP,Y
;
W !!,"This option will print "_TYPE
W " entries missing SEX, DOB, or SSN",!
W "data in the New Person file (#200)",!
;
S DIR(0)="YA",DIR("B")="Yes",DIR("A")="Do you wish to continue? "
S DIR("?")="Enter 'Yes' to continue or 'No' to quit"
D ^DIR K DIR ;ask user if they want to continue with option
Q:'Y!($D(DIRUT)) ;user responded No or with '^' to exit
;
;initialize task variables
S ZTDESC="New Person file Cleanup report"
S ZTRTN="EN1^XUPSCLR"
S ZTSAVE("TYPE")=TYPE
;
I TYPE="Detail Report of" D
. W !!,"The report may be lengthy. "
. W "It is suggested to queue the report."
D ZIS^XUPSUTQ ;does device selection and queueing if selected
Q:POP ;quit if task was queued
;
EN1 ;
;
N ACTIVE,DIR,DIRUT,DOB,SSN,FLG,I,IEN,MISS,MISSING,NODE,Y,PHONE
N NAME,PERSON,POP,SEX,TOTAL,VISITOR,X,XUPSDT,XUPSL,XUPSREC
;
D INIT
;
S IEN=.9
F S IEN=$O(^VA(200,IEN)) Q:'IEN D XXX
;
I $E(TYPE,1)="D" D ZZZ Q:FLG
;
D TOTALS
;
W:PERSON @IOF
;
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
;
Q
;
HEAD ; write report header
;
; pause and wait for user reponse before displaying next screen
I $E(IOST,1,2)="C-",NAME'="" D Q:FLG
.W !
.S DIR(0)="E" D ^DIR S FLG='Y
;
;if terminal clear screen first time
I $E(IOST,1,2)="C-",NAME="" W @IOF
;
;if printer do not form feed before printing first page
I NAME'="" W @IOF
;
W !,?1,"New Person file Assessment Report - "
W XUPSREC_" Persons",?55,XUPSDT
W !,?1,"Person Name",?31,"IEN",?40,"Missing",?48,"Missing"
W ?56,"Missing",?65,"Office Phone",!,?42,"SEX",?50,"DOB",?58,"SSN",!
;
Q
;
TOTALS ;
;if terminal pause after full screen
I $E(TYPE,1)="D",$E(IOST)="C" D Q:FLG
.S DIR(0)="E" D ^DIR
.S:'Y FLG=1
;
W @IOF
;W !,"NOTE: Visitor entries not included in totals other "
;W "than the Visitor total!",!
;
S XUPSL="Total Entries: " W !,?(50-$L(XUPSL)),XUPSL,$J(PERSON,6,0)
S XUPSL="Total Visitor Entries: "
W !,?(50-$L(XUPSL)),XUPSL,$J(VISITOR,6,0)
S XUPSL="(Visitor entries not included in the following counts)"
W !!,?(50-$L(XUPSL)),XUPSL
S XUPSL="Total Non-Visitor Entries: "
W !,?(50-$L(XUPSL)),XUPSL,$J(PERSON-VISITOR,6,0)
S XUPSL="Total Entries Missing Sex Code: "
W !,?(50-$L(XUPSL)),XUPSL,$J(MISSING("SEX"),6,0)
S XUPSL="Total Entries Missing DOB: "
W !,?(50-$L(XUPSL)),XUPSL,$J(MISSING("DOB"),6,0)
S XUPSL="Total Entries Missing SSN: "
W !,?(50-$L(XUPSL)),XUPSL,$J(MISSING("SSN"),6,0)
S XUPSL="Total Entries Missing One Data Element: "
W !,?(50-$L(XUPSL)),XUPSL,$J(MISS(1),6,0)
S XUPSL="Total Entries Missing Two Data Elements: "
W !,?(50-$L(XUPSL)),XUPSL,$J(MISS(2),6,0)
S XUPSL="Total Entries Missing Three Data Elements: "
W !,?(50-$L(XUPSL)),XUPSL,$J(MISS(3),6,0)
S XUPSL="Total Entries Missing Data: "
W !,?(50-$L(XUPSL)),XUPSL,$J(TOTAL("MISSING"),6,0)
S XUPSL="Total Active Entries: "
W !!,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("TOTAL"),6,0)
S XUPSL="Total Active Entries Missing Data: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("MISSING"),6,0)
S XUPSL="Total Active Entries Missing Sex Code: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("SEX"),6,0)
S XUPSL="Total Active Entries Missing DOB: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("DOB"),6,0)
S XUPSL="Total Active Entries Missing SSN: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE("SSN"),6,0)
S XUPSL="Total Active Entries Missing One Data Elements: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE(1),6,0)
S XUPSL="Total Active entries Missing Two Data Elements: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE(2),6,0)
S XUPSL="Total Active Entries Missing Three Data Elements: "
W !,?(50-$L(XUPSL)),XUPSL,$J(ACTIVE(3),6,0)
;
;pause before clearing screen if terminal
I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR
;
Q
;
XXX ;
S PERSON=PERSON+1 ;count IEN
;
; count visitors - quit if visitor
I '$$ACTIVE^XUSER(IEN),$D(^VA(200,IEN,8910)) D Q
.S VISITOR=VISITOR+1
;
; count active
I $$ACTIVE^XUSER(IEN) D
.S ACTIVE("TOTAL")=ACTIVE("TOTAL")+1,XUPSREC="Active"
;
; not active user
I '$$ACTIVE^XUSER(IEN) S XUPSREC="Inactive"
;
S (SEX,DOB,SSN)="" ;initialize missing data designator
S MISSING=0 ;initialize total missing for this entry
S NODE=$G(^VA(200,IEN,1)) ;get node where data is stored
;
I $P(NODE,"^",2)="" D ;sex is missing
.S SEX="X" ;flag as missing on report
.S MISSING("SEX")=MISSING("SEX")+1 ;add 1 to missing sex count
.S MISSING=MISSING+1 ;add 1 to missing data this entry count
.S:$$ACTIVE^XUSER(IEN) ACTIVE("SEX")=ACTIVE("SEX")+1
;
I $P(NODE,"^",3)="" D ;dob is missing
.S DOB="X" ;flag as missing on report
.S MISSING("DOB")=MISSING("DOB")+1 ;add 1 to missing dob count
.S MISSING=MISSING+1 ;add 1 to missing data this entry count
.S:$$ACTIVE^XUSER(IEN) ACTIVE("DOB")=ACTIVE("DOB")+1
;
I $P(NODE,"^",9)="" D ;ssn missing
.S SSN="X" ;flag as missing on report
.S MISSING("SSN")=MISSING("SSN")+1 ;add 1 to missing ssn count
.S MISSING=MISSING+1 ;add 1 to missing count this entry
.S:$$ACTIVE^XUSER(IEN) ACTIVE("SSN")=ACTIVE("SSN")+1
;
Q:'MISSING ;entry not missing any data, nothing to print
;
S TOTAL("MISSING")=TOTAL("MISSING")+1
;
I $$ACTIVE^XUSER(IEN) S ACTIVE("MISSING")=ACTIVE("MISSING")+1
;
I $$ACTIVE^XUSER(IEN) D
.S ACTIVE(MISSING)=ACTIVE(MISSING)+1
;
S MISS(MISSING)=MISS(MISSING)+1
;
I $E(TYPE,1)="D" D
.N X
.S PHONE=$P($G(^VA(200,IEN,.13)),"^",2)
.S X=PHONE_"^"_SEX_"^"_DOB_"^"_SSN
. I $P($G(^VA(200,IEN,0)),"^",1)="" Q
.S ^TMP($J,XUPSREC,$P(^VA(200,IEN,0),"^",1),IEN)=X
;
Q
;
INIT ; -- initialize
;
K ^TMP($J)
;
S (ACTIVE("MISSING"),ACTIVE("TOTAL"),TOTAL("MISSING"))=0
S (PERSON,VISITOR,FLG,ACTIVE)=0
;
F I=1:1:3 S (MISS(I),ACTIVE(I))=0
F I="SEX","DOB","SSN" S (ACTIVE(I),MISSING(I))=0
;
;get current date/time reformat to external form for header
N %,%I,%H D NOW^%DTC S Y=% D DD^%DT S XUPSDT=Y
;
Q
;
ZZZ ; -- detailed output
;
S XUPSREC="Active" D YYY Q:FLG
I $E(IOST,1,2)="C-" D Q:FLG
.W !
.S DIR(0)="E" D ^DIR
.S:'Y FLG=1
I $E(IOST,1,2)'="C-" W @IOF
;
S XUPSREC="Inactive" D YYY
;
Q
;
YYY ;
S NAME=""
;
D HEAD Q:FLG
;
F S NAME=$O(^TMP($J,XUPSREC,NAME)) Q:NAME=""!(FLG) D
.S IEN=0
.F S IEN=$O(^TMP($J,XUPSREC,NAME,IEN)) Q:'IEN!(FLG) D
..S NODE=^TMP($J,XUPSREC,NAME,IEN)
..S PHONE=$P(NODE,"^",1)
..S SEX=$P(NODE,"^",2)
..S DOB=$P(NODE,"^",3)
..S SSN=$P(NODE,"^",4)
..W !,$P(^VA(200,IEN,0),"^",1)
..W ?31,IEN,?43,SEX
..W ?51,DOB,?59,SSN,?65,PHONE
..I $Y>(IOSL-6) D HEAD
;
Q
;
XUPSCLR ;OIFO-CS/GRR/RAM/DW/PN - New Person file Cleanup Report ; 1 Jan 2004
+1 ;;8.0;KERNEL;**309**; Jul 10, 1995
+2 ;
+3 QUIT
+4 ;
DETAIL ; -- detailed report
+1 ;
+2 NEW TYPE
+3 ;
+4 SET TYPE="Detail Report of"
+5 ;
+6 DO EN
+7 ;
+8 QUIT
+9 ;
STATS ; -- totals only
+1 ;
+2 NEW TYPE
+3 ;
+4 SET TYPE="Statistical Report of"
+5 ;
+6 DO EN
+7 ;
+8 QUIT
+9 ;
EN ; -- entry point
+1 ;
+2 NEW ZTDESC,ZTSAVE,ZTIO,ZTDTH,X,ZTQUEUED,ZTREQ,ZTRTN,DIR,POP,Y
+3 ;
+4 WRITE !!,"This option will print "_TYPE
+5 WRITE " entries missing SEX, DOB, or SSN",!
+6 WRITE "data in the New Person file (#200)",!
+7 ;
+8 SET DIR(0)="YA"
SET DIR("B")="Yes"
SET DIR("A")="Do you wish to continue? "
+9 SET DIR("?")="Enter 'Yes' to continue or 'No' to quit"
+10 ;ask user if they want to continue with option
DO ^DIR
KILL DIR
+11 ;user responded No or with '^' to exit
IF 'Y!($DATA(DIRUT))
QUIT
+12 ;
+13 ;initialize task variables
+14 SET ZTDESC="New Person file Cleanup report"
+15 SET ZTRTN="EN1^XUPSCLR"
+16 SET ZTSAVE("TYPE")=TYPE
+17 ;
+18 IF TYPE="Detail Report of"
Begin DoDot:1
+19 WRITE !!,"The report may be lengthy. "
+20 WRITE "It is suggested to queue the report."
End DoDot:1
+21 ;does device selection and queueing if selected
DO ZIS^XUPSUTQ
+22 ;quit if task was queued
IF POP
QUIT
+23 ;
EN1 ;
+1 ;
+2 NEW ACTIVE,DIR,DIRUT,DOB,SSN,FLG,I,IEN,MISS,MISSING,NODE,Y,PHONE
+3 NEW NAME,PERSON,POP,SEX,TOTAL,VISITOR,X,XUPSDT,XUPSL,XUPSREC
+4 ;
+5 DO INIT
+6 ;
+7 SET IEN=.9
+8 FOR
SET IEN=$ORDER(^VA(200,IEN))
IF 'IEN
QUIT
DO XXX
+9 ;
+10 IF $EXTRACT(TYPE,1)="D"
DO ZZZ
IF FLG
QUIT
+11 ;
+12 DO TOTALS
+13 ;
+14 IF PERSON
WRITE @IOF
+15 ;
+16 DO ^%ZISC
+17 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+18 ;
+19 QUIT
+20 ;
HEAD ; write report header
+1 ;
+2 ; pause and wait for user reponse before displaying next screen
+3 IF $EXTRACT(IOST,1,2)="C-"
IF NAME'=""
Begin DoDot:1
+4 WRITE !
+5 SET DIR(0)="E"
DO ^DIR
SET FLG='Y
End DoDot:1
IF FLG
QUIT
+6 ;
+7 ;if terminal clear screen first time
+8 IF $EXTRACT(IOST,1,2)="C-"
IF NAME=""
WRITE @IOF
+9 ;
+10 ;if printer do not form feed before printing first page
+11 IF NAME'=""
WRITE @IOF
+12 ;
+13 WRITE !,?1,"New Person file Assessment Report - "
+14 WRITE XUPSREC_" Persons",?55,XUPSDT
+15 WRITE !,?1,"Person Name",?31,"IEN",?40,"Missing",?48,"Missing"
+16 WRITE ?56,"Missing",?65,"Office Phone",!,?42,"SEX",?50,"DOB",?58,"SSN",!
+17 ;
+18 QUIT
+19 ;
TOTALS ;
+1 ;if terminal pause after full screen
+2 IF $EXTRACT(TYPE,1)="D"
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET DIR(0)="E"
DO ^DIR
+4 IF 'Y
SET FLG=1
End DoDot:1
IF FLG
QUIT
+5 ;
+6 WRITE @IOF
+7 ;W !,"NOTE: Visitor entries not included in totals other "
+8 ;W "than the Visitor total!",!
+9 ;
+10 SET XUPSL="Total Entries: "
WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(PERSON,6,0)
+11 SET XUPSL="Total Visitor Entries: "
+12 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(VISITOR,6,0)
+13 SET XUPSL="(Visitor entries not included in the following counts)"
+14 WRITE !!,?(50-$LENGTH(XUPSL)),XUPSL
+15 SET XUPSL="Total Non-Visitor Entries: "
+16 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(PERSON-VISITOR,6,0)
+17 SET XUPSL="Total Entries Missing Sex Code: "
+18 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(MISSING("SEX"),6,0)
+19 SET XUPSL="Total Entries Missing DOB: "
+20 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(MISSING("DOB"),6,0)
+21 SET XUPSL="Total Entries Missing SSN: "
+22 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(MISSING("SSN"),6,0)
+23 SET XUPSL="Total Entries Missing One Data Element: "
+24 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(MISS(1),6,0)
+25 SET XUPSL="Total Entries Missing Two Data Elements: "
+26 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(MISS(2),6,0)
+27 SET XUPSL="Total Entries Missing Three Data Elements: "
+28 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(MISS(3),6,0)
+29 SET XUPSL="Total Entries Missing Data: "
+30 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(TOTAL("MISSING"),6,0)
+31 SET XUPSL="Total Active Entries: "
+32 WRITE !!,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE("TOTAL"),6,0)
+33 SET XUPSL="Total Active Entries Missing Data: "
+34 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE("MISSING"),6,0)
+35 SET XUPSL="Total Active Entries Missing Sex Code: "
+36 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE("SEX"),6,0)
+37 SET XUPSL="Total Active Entries Missing DOB: "
+38 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE("DOB"),6,0)
+39 SET XUPSL="Total Active Entries Missing SSN: "
+40 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE("SSN"),6,0)
+41 SET XUPSL="Total Active Entries Missing One Data Elements: "
+42 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE(1),6,0)
+43 SET XUPSL="Total Active entries Missing Two Data Elements: "
+44 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE(2),6,0)
+45 SET XUPSL="Total Active Entries Missing Three Data Elements: "
+46 WRITE !,?(50-$LENGTH(XUPSL)),XUPSL,$JUSTIFY(ACTIVE(3),6,0)
+47 ;
+48 ;pause before clearing screen if terminal
+49 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
+50 ;
+51 QUIT
+52 ;
XXX ;
+1 ;count IEN
SET PERSON=PERSON+1
+2 ;
+3 ; count visitors - quit if visitor
+4 IF '$$ACTIVE^XUSER(IEN)
IF $DATA(^VA(200,IEN,8910))
Begin DoDot:1
+5 SET VISITOR=VISITOR+1
End DoDot:1
QUIT
+6 ;
+7 ; count active
+8 IF $$ACTIVE^XUSER(IEN)
Begin DoDot:1
+9 SET ACTIVE("TOTAL")=ACTIVE("TOTAL")+1
SET XUPSREC="Active"
End DoDot:1
+10 ;
+11 ; not active user
+12 IF '$$ACTIVE^XUSER(IEN)
SET XUPSREC="Inactive"
+13 ;
+14 ;initialize missing data designator
SET (SEX,DOB,SSN)=""
+15 ;initialize total missing for this entry
SET MISSING=0
+16 ;get node where data is stored
SET NODE=$GET(^VA(200,IEN,1))
+17 ;
+18 ;sex is missing
IF $PIECE(NODE,"^",2)=""
Begin DoDot:1
+19 ;flag as missing on report
SET SEX="X"
+20 ;add 1 to missing sex count
SET MISSING("SEX")=MISSING("SEX")+1
+21 ;add 1 to missing data this entry count
SET MISSING=MISSING+1
+22 IF $$ACTIVE^XUSER(IEN)
SET ACTIVE("SEX")=ACTIVE("SEX")+1
End DoDot:1
+23 ;
+24 ;dob is missing
IF $PIECE(NODE,"^",3)=""
Begin DoDot:1
+25 ;flag as missing on report
SET DOB="X"
+26 ;add 1 to missing dob count
SET MISSING("DOB")=MISSING("DOB")+1
+27 ;add 1 to missing data this entry count
SET MISSING=MISSING+1
+28 IF $$ACTIVE^XUSER(IEN)
SET ACTIVE("DOB")=ACTIVE("DOB")+1
End DoDot:1
+29 ;
+30 ;ssn missing
IF $PIECE(NODE,"^",9)=""
Begin DoDot:1
+31 ;flag as missing on report
SET SSN="X"
+32 ;add 1 to missing ssn count
SET MISSING("SSN")=MISSING("SSN")+1
+33 ;add 1 to missing count this entry
SET MISSING=MISSING+1
+34 IF $$ACTIVE^XUSER(IEN)
SET ACTIVE("SSN")=ACTIVE("SSN")+1
End DoDot:1
+35 ;
+36 ;entry not missing any data, nothing to print
IF 'MISSING
QUIT
+37 ;
+38 SET TOTAL("MISSING")=TOTAL("MISSING")+1
+39 ;
+40 IF $$ACTIVE^XUSER(IEN)
SET ACTIVE("MISSING")=ACTIVE("MISSING")+1
+41 ;
+42 IF $$ACTIVE^XUSER(IEN)
Begin DoDot:1
+43 SET ACTIVE(MISSING)=ACTIVE(MISSING)+1
End DoDot:1
+44 ;
+45 SET MISS(MISSING)=MISS(MISSING)+1
+46 ;
+47 IF $EXTRACT(TYPE,1)="D"
Begin DoDot:1
+48 NEW X
+49 SET PHONE=$PIECE($GET(^VA(200,IEN,.13)),"^",2)
+50 SET X=PHONE_"^"_SEX_"^"_DOB_"^"_SSN
+51 IF $PIECE($GET(^VA(200,IEN,0)),"^",1)=""
QUIT
+52 SET ^TMP($JOB,XUPSREC,$PIECE(^VA(200,IEN,0),"^",1),IEN)=X
End DoDot:1
+53 ;
+54 QUIT
+55 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP($JOB)
+3 ;
+4 SET (ACTIVE("MISSING"),ACTIVE("TOTAL"),TOTAL("MISSING"))=0
+5 SET (PERSON,VISITOR,FLG,ACTIVE)=0
+6 ;
+7 FOR I=1:1:3
SET (MISS(I),ACTIVE(I))=0
+8 FOR I="SEX","DOB","SSN"
SET (ACTIVE(I),MISSING(I))=0
+9 ;
+10 ;get current date/time reformat to external form for header
+11 NEW %,%I,%H
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET XUPSDT=Y
+12 ;
+13 QUIT
+14 ;
ZZZ ; -- detailed output
+1 ;
+2 SET XUPSREC="Active"
DO YYY
IF FLG
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+4 WRITE !
+5 SET DIR(0)="E"
DO ^DIR
+6 IF 'Y
SET FLG=1
End DoDot:1
IF FLG
QUIT
+7 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+8 ;
+9 SET XUPSREC="Inactive"
DO YYY
+10 ;
+11 QUIT
+12 ;
YYY ;
+1 SET NAME=""
+2 ;
+3 DO HEAD
IF FLG
QUIT
+4 ;
+5 FOR
SET NAME=$ORDER(^TMP($JOB,XUPSREC,NAME))
IF NAME=""!(FLG)
QUIT
Begin DoDot:1
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^TMP($JOB,XUPSREC,NAME,IEN))
IF 'IEN!(FLG)
QUIT
Begin DoDot:2
+8 SET NODE=^TMP($JOB,XUPSREC,NAME,IEN)
+9 SET PHONE=$PIECE(NODE,"^",1)
+10 SET SEX=$PIECE(NODE,"^",2)
+11 SET DOB=$PIECE(NODE,"^",3)
+12 SET SSN=$PIECE(NODE,"^",4)
+13 WRITE !,$PIECE(^VA(200,IEN,0),"^",1)
+14 WRITE ?31,IEN,?43,SEX
+15 WRITE ?51,DOB,?59,SSN,?65,PHONE
+16 IF $Y>(IOSL-6)
DO HEAD
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT
+19 ;
