- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPSCLR 6977 printed Jan 18, 2025@03:12:51 Page 2
- 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 ;