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
