AMER1A.m

AMER1A ; IHS/ANMC/GIS -ISC - OVERFLOW FROM AMER1 ; 

 ;;3.0;ER VISIT SYSTEM;**2,5,8,9**;MAR 03, 2009;Build 4

 ;

QA1 ; ENTRY POINT FROM AMER1 ;NAME

 S DIC=2,DIC(0)="AEMQ"

 S DIC("A")="Enter the patient's NAME or LOCAL CHART NUMBER: "

 D ^DIC K DIC,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX

 I $D(DTOUT) K DTOUT S AMERQUIT="" Q

 I Y'=-1 S AMERDFN=+Y

 I Y'=-1,$D(^AMERADM("B",+Y)) S AMERRUN="EDIT" Q

 I Y'=-1 S Y=+Y Q

 I Y=-1,X'="" S AMERQUIT="" Q

 W !!,*7,"Do you want to register a new patient"

 S %=2 D YN^DICN I $D(DTOUT)!($E(%Y)=U) K DTOUT S AMERQUIT="" Q

 I "Nn"[$E(%Y) S AMERQUIT="" Q

 W !!,"Are you absolutely sure that this patient has never been registered",!,"here before"

 S %=2 D YN^DICN I $D(DTOUT)!($E(%Y)=U) K DTOUT S AMERQUIT="" Q

 I "Nn"[$E(%Y) D MSG G QA1

 S AMERRUN="REG"

 Q

 ;

MSG ; ENTRY POINT FROM AMER

 W !!!,"There are several tricks you can use to find this patient.  Try entering a"

 W !,"partial name like 'DOE,JO' instead of 'DOE,JOHN'.  Ask about other first"

 W !,"names and married names.  Try entering a date of birth in the format 9/9/99."

 W !,"This should narrow down the list of possible choices."

 W !!!

 Q

 ;

CHECK I '$D(^AMERADM("B")) W !!!,*7,"Sorry...I have no record of any current admissions to the ER.",!!! Q  ; EP FROM ^AMER2

PICK ;

 N A,B,C,Y,F,N,%,E,G

 K ^TMP("AMER TEMP",$J)

 W !,"The following patients are currently admitted to the ER =>",!!

 ;IHS/OIT/SCR - patch 2 start changes to order display

 ;W ?3,"NAME",?18,"DOB",?31,"CHART",?40,"ADMISSION",?59,"PRESENTING COMPLAINT"

 ;S %="",I=0,$P(%,"-",80)="" W !,%

 ;F N=0:0 S N=$O(^AMERADM(N)) Q:'N  S A=^(N,0) D PW

 S I=$$ADMDISP()  ;RETURNS THE COUNT

 ;Q:I<1

 I I<1 S AMERQUIT=""  ;IHS/OIT/SCR 10/14/09 patch 2 beta1

 W !

 Q

 ;PW ;

 ;I $D(AMERTRG),$P(^AMERADM(N,0),U,19)?1N.N Q

 ;S I=I+1,B=$P(^DPT(N,0),U),B=I_") "_$E(B,1,13),C=$P(A,U,9),E=$P(A,U,2),F=$P(A,U,10),G=$P(A,U,8),^TMP("AMER TEMP",$J,I,N)=""

 ;S F=$E(F,1,20),Y=E X ^DD("DD") S E=Y,Y=G X ^DD("DD") S G=Y

 ;W !,B,?18,G,?31,C,?40,E,?59,F

 ;Q

 ;IHS/OIT/SCR - patch 2 end changes to order display

ACT ; ENTRY POINT FROM MENU

 I $D(IOF) W @IOF

 D CHECK

 S DIR(0)="E",DIR("A")="Press 'Return to continue" D ^DIR

 I $D(IOF) W @IOF

 K DIR(0),DIR("A")

 Q

 ;

ADMDISP() ;IHS/OIT/SCR patch 2: Provides a toggle for display order

 N DIR,Y,AMERNUM

 S AMERNUM=-1

 S AMERNUM=$$SORTADM(1)

 W !

 ;IHS/OIT/SCR 10/15/09 patch 2 beta1 added next two lines

 I AMERNUM=0 W !,"All patients have been processed" Q AMERNUM

 I AMERNUM=1 Q AMERNUM

 S DIR(0)="Y",DIR("A")="Would you like to sort by ADMISSION time" S DIR("B")="N"

 D ^DIR

 I +Y=1 D

 .S AMERNUM=$$SORTADM(2)

 .W !

 .S DIR(0)="Y",DIR("A")="Would you like to sort by PATIENT NAME " S DIR("B")="N"

 .D ^DIR

 .I +Y=1 S AMERNUM=$$ADMDISP()

 .W !

 .Q

 Q AMERNUM

 ;

SORTADM(AMERSORT) ;IHS/OIT/SCR patch 2: Displays ER ADMISSION in identified order 

 N AMERNAME,AMERINDX,AMERARRY,AMERDOB,AMERCHRT,AMERCOMP,AMERTIME,AMERIDX2,AMERTIMF,AMERCNT

 I $G(AMERSORT)="" S AMERSORT=1

 S AMERINDX=0

 S AMERIDX2=0

 I AMERSORT=1 D

 .;SORT BY NAME

 .K ^TMP("AMER TEMP",$J)

 .F  S AMERINDX=$O(^AMERADM(AMERINDX)) Q:AMERINDX="B"  D

 ..I $D(AMERTRG),$P(^AMERADM(AMERINDX,0),U,19)?1N.N Q   ;IHS/OIT/SCR 10/14/09 patch 2 beta1

 ..S AMERNAME=$P($G(^DPT(AMERINDX,0)),"^",1)

 ..Q:AMERNAME=""

 ..I $G(AMERARRY(AMERNAME))'="" D

 ...S AMERARRY(AMERNAME,AMERIDX2)=AMERINDX

 ...S AMERIDX2=AMERIDX2+1

 ...Q

 ..I $G(AMERARRY(AMERNAME))="" D

 ...S AMERIDX2=0

 ...S AMERARRY(AMERNAME)=AMERINDX

 ..Q

 .S AMERCNT=0

 .Q:'$D(AMERARRY)  ;IHS/OIT/SCR 10/14/09 patch 2 beta1

 .W !!,?3,"NAME",?18,"DOB",?31,"CHART",?40,"ADMISSION",?59,"PRESENTING COMPLAINT",!

 .S AMERINDX=""

 .F  S AMERINDX=$O(AMERARRY(AMERINDX)) Q:AMERINDX=""  D

 ..S AMERNAME=AMERINDX

 ..S AMERCNT=AMERCNT+1

 ..S AMERDPT=$G(AMERARRY(AMERNAME))

 ..S ^TMP("AMER TEMP",$J,AMERCNT,AMERDPT)=""

 ..S AMERDOB=$P($G(^AMERADM(AMERDPT,0)),"^",8)

 ..S Y=AMERDOB X ^DD("DD") S AMERDOB=Y  ;FORMAT DATE

 ..S AMERCHRT=$P($G(^AMERADM(AMERDPT,0)),"^",9)

 ..S AMERTIME=$P($G(^AMERADM(AMERDPT,0)),"^",2)

 ..S Y=AMERTIME X ^DD("DD") S AMERTIME=Y

 ..;AMER*3.0*8;Switched to field 23

 ..;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 ..S AMERCOMP=$P($G(^AMERADM(AMERDPT,23)),"^",1)

 ..S AMERCOMP=$E(AMERCOMP,1,21)

 ..S AMERNAME=$E(AMERNAME,1,13)

 ..W !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIME,?59,AMERCOMP

 ..;

 ..;AMER*3*5;Added auditing call

 ..D LOG^AMERBUSA("P","Q","AMER1A","AMER: ER Patient Listing",AMERDPT)

 ..; 

 ..S AMERIDX2=0

 ..F  S AMERIDX2=$O(AMERARRY(AMERINDX,AMERIDX2)) Q:AMERIDX2=""  D

 ...S AMERCNT=AMERCNT+1

 ...S AMERTIME=AMERINDX

 ...S AMERDPT=$G(AMERARRY(AMERNAME,AMERIDX2))

 ...S ^TMP("AMER TEMP",$J,AMERCNT,AMERDPT)=""

 ...S AMERNAME=AMERINDX

 ...S AMERNAME=$E(AMERNAME,1,13)

 ...S AMERDOB=$P($G(^AMERADM(AMERDPT,0)),"^",8)

 ...S Y=AMERDOB X ^DD("DD") S AMERDOB=Y  ;FORMAT DATE

 ...S AMERCHRT=$P($G(^AMERADM(AMERDPT,0)),"^",9)

 ...S Y=AMERTIME X ^DD("DD") S AMERTIME=Y

 ...;AMER*3.0*9;Switched to field 23

 ...;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 ...S AMERCOMP=$P($G(^AMERADM(AMERDPT,23)),"^",1)

 ...S AMERCOMP=$E(AMERCOMP,1,21)

 ...W !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIME,?59,AMERCOMP

 ...Q

 ..Q

 .Q

 I AMERSORT=2 D

 .;SORT BY ADMISSION TIME STAMP

 .K ^TMP("AMER TEMP",$J)

 .F  S AMERINDX=$O(^AMERADM(AMERINDX)) Q:AMERINDX="B"  D

 ..I $D(AMERTRG),$P(^AMERADM(AMERINDX,0),U,19)?1N.N Q   ;IHS/OIT/SCR 10/14/09 patch 2 beta1

 ..S AMERTIME=$P($G(^AMERADM(AMERINDX,0)),"^",2)

 ..Q:AMERTIME=""

 ..I $G(AMERARRY(AMERTIME))'="" D

 ...S AMERARRY(AMERTIME,AMERIDX2)=AMERINDX

 ...S AMERIDX2=AMERIDX2+1

 ...Q

 ..I $G(AMERARRY(AMERTIME))="" D

 ...S AMERIDX2=0

 ...S AMERARRY(AMERTIME)=AMERINDX

 ..Q

 .S AMERINDX=""

 .S AMERCNT=0

 .Q:'$D(AMERARRY)  ;IHS/OIT/SCR 10/14/09 patch 2 beta1

 .W !!

 .W !,?3,"NAME",?18,"DOB",?31,"CHART",?40,"ADMISSION",?59,"PRESENTING COMPLAINT",!

 .F  S AMERINDX=$O(AMERARRY(AMERINDX)) Q:AMERINDX=""  D

 ..S AMERCNT=AMERCNT+1

 ..S AMERTIME=AMERINDX

 ..S AMERDPT=$G(AMERARRY(AMERTIME))

 ..S ^TMP("AMER TEMP",$J,AMERCNT,AMERDPT)=""

 ..S AMERNAME=$P($G(^DPT(AMERDPT,0)),"^",1)

 ..S AMERNAME=$E(AMERNAME,1,13)

 ..S AMERDOB=$P($G(^AMERADM(AMERDPT,0)),"^",8)

 ..S Y=AMERDOB X ^DD("DD") S AMERDOB=Y  ;FORMAT DATE

 ..S AMERCHRT=$P($G(^AMERADM(AMERDPT,0)),"^",9)

 ..S Y=AMERTIME X ^DD("DD") S AMERTIMF=Y

 ..;AMER*3.0*9;Switched to field 23

 ..;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 ..S AMERCOMP=$P($G(^AMERADM(AMERDPT,23)),"^",1)

 ..S AMERCOMP=$E(AMERCOMP,1,21)

 ..W !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIMF,?59,AMERCOMP

 ..S AMERIDX2=""

 ..F  S AMERIDX2=$O(AMERARRY(AMERTIME,AMERIDX2)) Q:AMERIDX2=""  D

 ...S AMERCNT=AMERCNT+1

 ...S AMERTIME=AMERINDX

 ...S AMERDPT=$G(AMERARRY(AMERINDX,AMERIDX2))

 ...S ^TMP("AMER TEMP",$J,AMERCNT,AMERDPT)=""

 ...S AMERNAME=$P($G(^DPT(AMERDPT,0)),"^",1)

 ...S AMERNAME=$E(AMERNAME,1,13)

 ...S AMERDOB=$P($G(^AMERADM(AMERDPT,0)),"^",8)

 ...S Y=AMERDOB X ^DD("DD") S AMERDOB=Y  ;FORMAT DATE

 ...S AMERCHRT=$P($G(^AMERADM(AMERDPT,0)),"^",9)

 ...S Y=AMERTIME X ^DD("DD") S AMERTIMF=Y

 ...;AMER*3.0*9;Switched to field 23

 ...;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 ...S AMERCOMP=$P($G(^AMERADM(AMERDPT,23)),"^",1)

 ...S AMERCOMP=$E(AMERCOMP,1,21)

 ...W !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIMF,?59,AMERCOMP

 ...Q

 ..Q

 .Q

 Q AMERCNT

AMER1A    ; IHS/ANMC/GIS -ISC - OVERFLOW FROM AMER1 ; 

 +1       ;;3.0;ER VISIT SYSTEM;**2,5,8,9**;MAR 03, 2009;Build 4

 +2       ;

QA1       ; ENTRY POINT FROM AMER1 ;NAME

 +1        SET DIC=2

           SET DIC(0)="AEMQ"

 +2        SET DIC("A")="Enter the patient's NAME or LOCAL CHART NUMBER: "

 +3        DO ^DIC

           KILL DIC,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX

 +4        IF $DATA(DTOUT)

               KILL DTOUT

               SET AMERQUIT=""

               QUIT 

 +5        IF Y'=-1

               SET AMERDFN=+Y

 +6        IF Y'=-1

               IF $DATA(^AMERADM("B",+Y))

                   SET AMERRUN="EDIT"

                   QUIT 

 +7        IF Y'=-1

               SET Y=+Y

               QUIT 

 +8        IF Y=-1

               IF X'=""

                   SET AMERQUIT=""

                   QUIT 

 +9        WRITE !!,*7,"Do you want to register a new patient"

 +10       SET %=2

           DO YN^DICN

           IF $DATA(DTOUT)!($EXTRACT(%Y)=U)

               KILL DTOUT

               SET AMERQUIT=""

               QUIT 

 +11       IF "Nn"[$EXTRACT(%Y)

               SET AMERQUIT=""

               QUIT 

 +12       WRITE !!,"Are you absolutely sure that this patient has never been registered",!,"here before"

 +13       SET %=2

           DO YN^DICN

           IF $DATA(DTOUT)!($EXTRACT(%Y)=U)

               KILL DTOUT

               SET AMERQUIT=""

               QUIT 

 +14       IF "Nn"[$EXTRACT(%Y)

               DO MSG

               GOTO QA1

 +15       SET AMERRUN="REG"

 +16       QUIT 

 +17      ;

MSG       ; ENTRY POINT FROM AMER

 +1        WRITE !!!,"There are several tricks you can use to find this patient.  Try entering a"

 +2        WRITE !,"partial name like 'DOE,JO' instead of 'DOE,JOHN'.  Ask about other first"

 +3        WRITE !,"names and married names.  Try entering a date of birth in the format 9/9/99."

 +4        WRITE !,"This should narrow down the list of possible choices."

 +5        WRITE !!!

 +6        QUIT 

 +7       ;

CHECK     ; EP FROM ^AMER2

           IF '$DATA(^AMERADM("B"))

               WRITE !!!,*7,"Sorry...I have no record of any current admissions to the ER.",!!!

               QUIT 

PICK      ;

 +1        NEW A,B,C,Y,F,N,%,E,G

 +2        KILL ^TMP("AMER TEMP",$JOB)

 +3        WRITE !,"The following patients are currently admitted to the ER =>",!!

 +4       ;IHS/OIT/SCR - patch 2 start changes to order display

 +5       ;W ?3,"NAME",?18,"DOB",?31,"CHART",?40,"ADMISSION",?59,"PRESENTING COMPLAINT"

 +6       ;S %="",I=0,$P(%,"-",80)="" W !,%

 +7       ;F N=0:0 S N=$O(^AMERADM(N)) Q:'N  S A=^(N,0) D PW

 +8       ;RETURNS THE COUNT

           SET I=$$ADMDISP()

 +9       ;Q:I<1

 +10      ;IHS/OIT/SCR 10/14/09 patch 2 beta1

           IF I<1

               SET AMERQUIT=""

 +11       WRITE !

 +12       QUIT 

 +13      ;PW ;

 +14      ;I $D(AMERTRG),$P(^AMERADM(N,0),U,19)?1N.N Q

 +15      ;S I=I+1,B=$P(^DPT(N,0),U),B=I_") "_$E(B,1,13),C=$P(A,U,9),E=$P(A,U,2),F=$P(A,U,10),G=$P(A,U,8),^TMP("AMER TEMP",$J,I,N)=""

 +16      ;S F=$E(F,1,20),Y=E X ^DD("DD") S E=Y,Y=G X ^DD("DD") S G=Y

 +17      ;W !,B,?18,G,?31,C,?40,E,?59,F

 +18      ;Q

 +19      ;IHS/OIT/SCR - patch 2 end changes to order display

ACT       ; ENTRY POINT FROM MENU

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        DO CHECK

 +3        SET DIR(0)="E"

           SET DIR("A")="Press 'Return to continue"

           DO ^DIR

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        KILL DIR(0),DIR("A")

 +6        QUIT 

 +7       ;

ADMDISP() ;IHS/OIT/SCR patch 2: Provides a toggle for display order

 +1        NEW DIR,Y,AMERNUM

 +2        SET AMERNUM=-1

 +3        SET AMERNUM=$$SORTADM(1)

 +4        WRITE !

 +5       ;IHS/OIT/SCR 10/15/09 patch 2 beta1 added next two lines

 +6        IF AMERNUM=0

               WRITE !,"All patients have been processed"

               QUIT AMERNUM

 +7        IF AMERNUM=1

               QUIT AMERNUM

 +8        SET DIR(0)="Y"

           SET DIR("A")="Would you like to sort by ADMISSION time"

           SET DIR("B")="N"

 +9        DO ^DIR

 +10       IF +Y=1

               Begin DoDot:1

 +11               SET AMERNUM=$$SORTADM(2)

 +12               WRITE !

 +13               SET DIR(0)="Y"

                   SET DIR("A")="Would you like to sort by PATIENT NAME "

                   SET DIR("B")="N"

 +14               DO ^DIR

 +15               IF +Y=1

                       SET AMERNUM=$$ADMDISP()

 +16               WRITE !

 +17               QUIT 

               End DoDot:1

 +18       QUIT AMERNUM

 +19      ;

SORTADM(AMERSORT) ;IHS/OIT/SCR patch 2: Displays ER ADMISSION in identified order 

 +1        NEW AMERNAME,AMERINDX,AMERARRY,AMERDOB,AMERCHRT,AMERCOMP,AMERTIME,AMERIDX2,AMERTIMF,AMERCNT

 +2        IF $GET(AMERSORT)=""

               SET AMERSORT=1

 +3        SET AMERINDX=0

 +4        SET AMERIDX2=0

 +5        IF AMERSORT=1

               Begin DoDot:1

 +6       ;SORT BY NAME

 +7                KILL ^TMP("AMER TEMP",$JOB)

 +8                FOR 

                       SET AMERINDX=$ORDER(^AMERADM(AMERINDX))

                       IF AMERINDX="B"

                           QUIT 

                       Begin DoDot:2

 +9       ;IHS/OIT/SCR 10/14/09 patch 2 beta1

                           IF $DATA(AMERTRG)

                               IF $PIECE(^AMERADM(AMERINDX,0),U,19)?1N.N

                                   QUIT 

 +10                       SET AMERNAME=$PIECE($GET(^DPT(AMERINDX,0)),"^",1)

 +11                       IF AMERNAME=""

                               QUIT 

 +12                       IF $GET(AMERARRY(AMERNAME))'=""

                               Begin DoDot:3

 +13                               SET AMERARRY(AMERNAME,AMERIDX2)=AMERINDX

 +14                               SET AMERIDX2=AMERIDX2+1

 +15                               QUIT 

                               End DoDot:3

 +16                       IF $GET(AMERARRY(AMERNAME))=""

                               Begin DoDot:3

 +17                               SET AMERIDX2=0

 +18                               SET AMERARRY(AMERNAME)=AMERINDX

                               End DoDot:3

 +19                       QUIT 

                       End DoDot:2

 +20               SET AMERCNT=0

 +21      ;IHS/OIT/SCR 10/14/09 patch 2 beta1

                   IF '$DATA(AMERARRY)

                       QUIT 

 +22               WRITE !!,?3,"NAME",?18,"DOB",?31,"CHART",?40,"ADMISSION",?59,"PRESENTING COMPLAINT",!

 +23               SET AMERINDX=""

 +24               FOR 

                       SET AMERINDX=$ORDER(AMERARRY(AMERINDX))

                       IF AMERINDX=""

                           QUIT 

                       Begin DoDot:2

 +25                       SET AMERNAME=AMERINDX

 +26                       SET AMERCNT=AMERCNT+1

 +27                       SET AMERDPT=$GET(AMERARRY(AMERNAME))

 +28                       SET ^TMP("AMER TEMP",$JOB,AMERCNT,AMERDPT)=""

 +29                       SET AMERDOB=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",8)

 +30      ;FORMAT DATE

                           SET Y=AMERDOB

                           XECUTE ^DD("DD")

                           SET AMERDOB=Y

 +31                       SET AMERCHRT=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",9)

 +32                       SET AMERTIME=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",2)

 +33                       SET Y=AMERTIME

                           XECUTE ^DD("DD")

                           SET AMERTIME=Y

 +34      ;AMER*3.0*8;Switched to field 23

 +35      ;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 +36                       SET AMERCOMP=$PIECE($GET(^AMERADM(AMERDPT,23)),"^",1)

 +37                       SET AMERCOMP=$EXTRACT(AMERCOMP,1,21)

 +38                       SET AMERNAME=$EXTRACT(AMERNAME,1,13)

 +39                       WRITE !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIME,?59,AMERCOMP

 +40      ;

 +41      ;AMER*3*5;Added auditing call

 +42                       DO LOG^AMERBUSA("P","Q","AMER1A","AMER: ER Patient Listing",AMERDPT)

 +43      ; 

 +44                       SET AMERIDX2=0

 +45                       FOR 

                               SET AMERIDX2=$ORDER(AMERARRY(AMERINDX,AMERIDX2))

                               IF AMERIDX2=""

                                   QUIT 

                               Begin DoDot:3

 +46                               SET AMERCNT=AMERCNT+1

 +47                               SET AMERTIME=AMERINDX

 +48                               SET AMERDPT=$GET(AMERARRY(AMERNAME,AMERIDX2))

 +49                               SET ^TMP("AMER TEMP",$JOB,AMERCNT,AMERDPT)=""

 +50                               SET AMERNAME=AMERINDX

 +51                               SET AMERNAME=$EXTRACT(AMERNAME,1,13)

 +52                               SET AMERDOB=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",8)

 +53      ;FORMAT DATE

                                   SET Y=AMERDOB

                                   XECUTE ^DD("DD")

                                   SET AMERDOB=Y

 +54                               SET AMERCHRT=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",9)

 +55                               SET Y=AMERTIME

                                   XECUTE ^DD("DD")

                                   SET AMERTIME=Y

 +56      ;AMER*3.0*9;Switched to field 23

 +57      ;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 +58                               SET AMERCOMP=$PIECE($GET(^AMERADM(AMERDPT,23)),"^",1)

 +59                               SET AMERCOMP=$EXTRACT(AMERCOMP,1,21)

 +60                               WRITE !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIME,?59,AMERCOMP

 +61                               QUIT 

                               End DoDot:3

 +62                       QUIT 

                       End DoDot:2

 +63               QUIT 

               End DoDot:1

 +64       IF AMERSORT=2

               Begin DoDot:1

 +65      ;SORT BY ADMISSION TIME STAMP

 +66               KILL ^TMP("AMER TEMP",$JOB)

 +67               FOR 

                       SET AMERINDX=$ORDER(^AMERADM(AMERINDX))

                       IF AMERINDX="B"

                           QUIT 

                       Begin DoDot:2

 +68      ;IHS/OIT/SCR 10/14/09 patch 2 beta1

                           IF $DATA(AMERTRG)

                               IF $PIECE(^AMERADM(AMERINDX,0),U,19)?1N.N

                                   QUIT 

 +69                       SET AMERTIME=$PIECE($GET(^AMERADM(AMERINDX,0)),"^",2)

 +70                       IF AMERTIME=""

                               QUIT 

 +71                       IF $GET(AMERARRY(AMERTIME))'=""

                               Begin DoDot:3

 +72                               SET AMERARRY(AMERTIME,AMERIDX2)=AMERINDX

 +73                               SET AMERIDX2=AMERIDX2+1

 +74                               QUIT 

                               End DoDot:3

 +75                       IF $GET(AMERARRY(AMERTIME))=""

                               Begin DoDot:3

 +76                               SET AMERIDX2=0

 +77                               SET AMERARRY(AMERTIME)=AMERINDX

                               End DoDot:3

 +78                       QUIT 

                       End DoDot:2

 +79               SET AMERINDX=""

 +80               SET AMERCNT=0

 +81      ;IHS/OIT/SCR 10/14/09 patch 2 beta1

                   IF '$DATA(AMERARRY)

                       QUIT 

 +82               WRITE !!

 +83               WRITE !,?3,"NAME",?18,"DOB",?31,"CHART",?40,"ADMISSION",?59,"PRESENTING COMPLAINT",!

 +84               FOR 

                       SET AMERINDX=$ORDER(AMERARRY(AMERINDX))

                       IF AMERINDX=""

                           QUIT 

                       Begin DoDot:2

 +85                       SET AMERCNT=AMERCNT+1

 +86                       SET AMERTIME=AMERINDX

 +87                       SET AMERDPT=$GET(AMERARRY(AMERTIME))

 +88                       SET ^TMP("AMER TEMP",$JOB,AMERCNT,AMERDPT)=""

 +89                       SET AMERNAME=$PIECE($GET(^DPT(AMERDPT,0)),"^",1)

 +90                       SET AMERNAME=$EXTRACT(AMERNAME,1,13)

 +91                       SET AMERDOB=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",8)

 +92      ;FORMAT DATE

                           SET Y=AMERDOB

                           XECUTE ^DD("DD")

                           SET AMERDOB=Y

 +93                       SET AMERCHRT=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",9)

 +94                       SET Y=AMERTIME

                           XECUTE ^DD("DD")

                           SET AMERTIMF=Y

 +95      ;AMER*3.0*9;Switched to field 23

 +96      ;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 +97                       SET AMERCOMP=$PIECE($GET(^AMERADM(AMERDPT,23)),"^",1)

 +98                       SET AMERCOMP=$EXTRACT(AMERCOMP,1,21)

 +99                       WRITE !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIMF,?59,AMERCOMP

 +100                      SET AMERIDX2=""

 +101                      FOR 

                               SET AMERIDX2=$ORDER(AMERARRY(AMERTIME,AMERIDX2))

                               IF AMERIDX2=""

                                   QUIT 

                               Begin DoDot:3

 +102                              SET AMERCNT=AMERCNT+1

 +103                              SET AMERTIME=AMERINDX

 +104                              SET AMERDPT=$GET(AMERARRY(AMERINDX,AMERIDX2))

 +105                              SET ^TMP("AMER TEMP",$JOB,AMERCNT,AMERDPT)=""

 +106                              SET AMERNAME=$PIECE($GET(^DPT(AMERDPT,0)),"^",1)

 +107                              SET AMERNAME=$EXTRACT(AMERNAME,1,13)

 +108                              SET AMERDOB=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",8)

 +109     ;FORMAT DATE

                                   SET Y=AMERDOB

                                   XECUTE ^DD("DD")

                                   SET AMERDOB=Y

 +110                              SET AMERCHRT=$PIECE($GET(^AMERADM(AMERDPT,0)),"^",9)

 +111                              SET Y=AMERTIME

                                   XECUTE ^DD("DD")

                                   SET AMERTIMF=Y

 +112     ;AMER*3.0*9;Switched to field 23

 +113     ;S AMERCOMP=$P($G(^AMERADM(AMERDPT,0)),"^",10)

 +114                              SET AMERCOMP=$PIECE($GET(^AMERADM(AMERDPT,23)),"^",1)

 +115                              SET AMERCOMP=$EXTRACT(AMERCOMP,1,21)

 +116                              WRITE !,AMERCNT_")",?3,AMERNAME,?18,AMERDOB,?31,AMERCHRT,?40,AMERTIMF,?59,AMERCOMP

 +117                              QUIT 

                               End DoDot:3

 +118                      QUIT 

                       End DoDot:2

 +119              QUIT 

               End DoDot:1

 +120      QUIT AMERCNT