AMER2 ; IHS/ANMC/GIS - ER DISCHARGE DATA COLLECTION ;
;;3.0;ER VISIT SYSTEM;**1,2,6**;MAR 03, 2009;Build 30
;
QD1 ; NAME
I $D(AMERDNA) W !,?5,"***** PROCESS PATIENT WHO LEFT BEFORE VISIT WAS COMPLETED *****",!!,*7
D PICK K ^TMP("AMER TEMP",$J) I $D(AMERQUIT) Q
D UTL^AMER0(AMERDFN) S (X,Y)=AMERDFN
I $D(AMERDNA) S AMERRUN=12 Q
S AMERRUN=19
Q
;
QD2 ; INJURY
;
;Pull information from Dashboard if populated
NEW AMERPCC,INJ
S AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I") I AMERPCC]"",$T(INJURY^BEDDINJ)]"" D
. NEW INJ,EXEC
. ;
. ;Make the dashboard retrieval call
. S EXEC="D INJURY^BEDDINJ(AMERPCC,.INJ)" X EXEC
. ;
. ;If injury not set quit
. I $G(INJ("ISINJ"))'="YES" Q
. ;
. ;Fill in information
. S ^TMP("AMER",$J,2,2)=1 ;Is Injury
. S ^TMP("AMER",$J,2,31)=$G(INJ("INLOC")) ;Injury Town
. S ^TMP("AMER",$J,2,32)=$G(INJ("INDAT")) ;Injury Date/Time
. S ^TMP("AMER",$J,2,33)=$G(INJ("ICIEN")) ;Injury Cause
. S ^TMP("AMER",$J,2,34)=$G(INJ("INSET")) ;Injury Setting
. S ^TMP("AMER",$J,2,35)=$G(INJ("INJEQ")) ;Injury Safety
. S ^TMP("AMER",$J,2,42)=$G(INJ("INSCO")) ;Driver Insurance Co
. S ^TMP("AMER",$J,2,43)=$G(INJ("INSPO")) ;Driver Policy Number
. S ^TMP("AMER",$J,2,41)=$G(INJ("MVLOC")) ;MVC Location
. S ^TMP("AMER",$J,2,5)=$G(INJ("WKREL")) ;Work related
;
S DIR("B")="NO" I $G(^TMP("AMER",$J,2,2)) S DIR("B")="YES"
S DIR(0)="YO",DIR("A")="*Was this ER visit caused by an injury" D ^DIR K DIR
D OUT^AMER
;
;AMER*3.0*6;Added call to update BEDD
I Y'["^" S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.Injury",INJ)
;
I Y=U,'$D(AMEREFLG) S AMERFIN=28,AMERRUN=27 Q
I 'Y,'$G(^TMP("AMER",$J,2,2)),$D(AMEREFLG) S AMERRUN=98 Q
I Y S AMERRUN=29,AMERFIN=71 Q
F I=32:1:35,41:1:46,51:1:57,61:1:64,70 K ^TMP("AMER",$J,2,I) ; KILL OFF ALL DESCENDENTS
S AMERRUN=4
Q
;
QD5 ; WORK RELATED
S DIR("B")="NO" I $G(^TMP("AMER",$J,2,5)) S DIR("B")="YES"
S DIR(0)="YO",DIR("A")="*Was this ER visit WORK-RELATED" D ^DIR K DIR
D OUT^AMER I X=U,'$D(AMEREFLG) ;S AMERFIN=27
;
;AMER*3.0*6;Added call to update BEDD
NEW INJ
I Y'["^" S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.PtInjury.WrkRel",INJ)
K INJ
;
Q
QD6 ; ER CONSULTANT NOTIFIED
N DIR
S DIR("B")="NO" I $G(^TMP("AMER",$J,2,6)) S DIR("B")="YES"
S DIR(0)="YO",DIR("A")="*Was an ER CONSULTANT notified" D ^DIR K DIR
D OUT^AMER I X?1."^" Q
I 'Y K ^TMP("AMER",$J,2,7) S ^TMP("AMER",$J,2,6)=0,AMERRUN=9
I 'Y,$D(AMEREFLG) S AMERRUN=98
I 'Y Q
S ^TMP("AMER",$J,2,6)=1
Q
;
QD7 ; ER CONSULTANT TYPE
S AMERRUN=9
N AMERSNO,AMERO,AMERDEL,AMERREM,AMERSTOP,DIC,DIR
S AMERSNO=1,AMERO=0,AMERREM=0,AMERSTOP=""
F S AMERO=$O(^TMP("AMER",$J,2,7,AMERO)) Q:'AMERO S AMERSNO=AMERSNO+1
F Q:AMERSTOP="^" D
.S AMERREM=0
.S DIC="^AMER(2.9,",DIC(0)="AMEQ",Y="",DIC("S")="I $P(^(0),U,2)="""""
.S AMEROPT="",DIC("A")="*CONSULTANT SERVICE: "
.S DIC("B")=$P($G(^TMP("AMER",$J,2,7,1)),U,2)
.D ^DIC
.I X="",AMERSNO=1 D
..S AMERO=0
..S AMERO=$O(^TMP("AMER",$J,2,7,AMERO))
..I AMERO="" K ^TMP("AMER",$J,2,7) D EN^DDIOL("No ER CONSULTANT notified","","!!")
..S AMERSTOP="^"
..Q
.I X?2."^" S DIROUT="",AMERSTOP="^"
.I "^"[$E(X) S AMERSTOP="^",AMERRUN=9 Q
.S ^TMP("AMER",$J,2,7,AMERSNO)=Y
.S ^TMP("AMER",$J,2,7,AMERSNO,.01)=+Y
.S AMERO=0
.F S AMERO=$O(^TMP("AMER",$J,2,7,AMERO)) Q:'AMERO D
..I AMERO'=AMERSNO&($P($G(^TMP("AMER",$J,2,7,AMERO)),U,1)=+Y) D ;DUPLICATE ENTRY
...K ^TMP("AMER",$J,2,7,AMERSNO) ;WE JUST ADDED A DUPLICATE TO THE TEMP GLOBAL AND WE WANT IT GONE
...S AMERREM=$$REM()
...K:AMERREM ^TMP("AMER",$J,2,7,AMERO) ;IF USER ANSWERS YES, DELETE THE ORIGINAL ENTRY
...Q
..Q
.Q:AMERREM=1
.I $E(X)=U S AMERQUIT="",AMERRUN=9 Q
.D QD8 ;to set time
.;Get name
.I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT S AMERSTOP="^" Q
.K DIC("B")
.I $G(^TMP("AMER",$J,2,7,AMERSNO,.03)) S DIC("B")=^TMP("AMER",$J,2,7,AMERSNO,.03)
.S DIC("A")="*CONSULTANT NAME: "
.S DIC="^VA(200,",DIC(0)="AEQ"
.S DIC("?")="Only active providers can be selected"
.;screening so that only valid PCC providers identified
.S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
.D ^DIC K DIC
.;IHS/OIT/SCR 5/11/09 - REQUIRE CONSULTANT TIME AND NAME OR REMOVE ENTRY
.;I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT S AMERSTOP="^" Q
.I $D(DUOUT)!$D(DTOUT)!(Y<0) D Q
..K DUOUT,DTOUT S AMERSTOP="^"
..K ^TMP("AMER",$J,2,7,AMERSNO)
..D EN^DDIOL("No Provider Identified!","","!!")
..D EN^DDIOL("Consultant Entry not saved","","!")
..Q
.S:Y>0 ^TMP("AMER",$J,2,7,AMERSNO,.03)=+Y,^TMP("AMER",$J,2,7,AMERSNO)=$G(^TMP("AMER",$J,2,7,AMERSNO))_"^"_Y
.S DIR("A")="*Was another CONSULTANT notified"
.S DIR(0)="Y",DIR("B")="NO"
.D ^DIR
.I Y=1 D
..S AMERSNO=AMERSNO+1,AMEROPT="",AMERSTOP=""
..F S AMERO=$O(^TMP("AMER",$J,2,7,AMERO)) Q:'AMERO S AMERSNO=AMERSNO+1
..Q
.E S AMERSTOP="^"
.Q
;if there are no ER CONSUTANTS entered, make sure ER CONSULTANT notified field is NO
K AMERSNO,AMERO,AMERDEL,AMERREM,AMERSTOP,DIC,DIR
Q
;
QD8 ; ER CONSULTANT TIME
N Y,DIR
I $G(^TMP("AMER",$J,2,7,AMERSNO,.02)) S Y=^TMP("AMER",$J,2,7,AMERSNO,.02) X ^DD("DD") S DIR("B")=Y
;S DIR(0)="DO^::ER",DIR("A")="*What time did the patient see this CONSULTANT"
S DIR(0)="D^::ER",DIR("A")="*What time did the patient see this CONSULTANT" ;IHS/OIT/SCR 050509 Patch 1
S DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)"
D ^DIR K DIR
I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,1,2)),Y,1,"admission") K Y G QD8
I Y,$$TVAL^AMER2A($G(^TMP("AMER",$J,1,2)),Y,4) K Y G QD8
E D
.S ^TMP("AMER",$J,2,7,AMERSNO,.02)=Y
.S ^TMP("AMER",$J,2,7,AMERSNO)=$G(^TMP("AMER",$J,2,7,AMERSNO))_"^"_Y
Q
;
REM(AMERO) ;
S DIR("A")="This consultant type has already been identified. Do you want to remove it"
S DIR(0)="Y",DIR("B")="NO"
D ^DIR
I Y=1 Q 1
Q 0
;
TCK(Z,T,X,A) ; TIME CHECK WHERE Z=TIME,T=COMPARISON TIME,X=1:AFTER,X=0:BEFORE AND A=NARRATIVE
N %,Y
I $G(Z)=""!($G(A)="") Q ""
S Y=Z X ^DD("DD")
I X,T>Z Q 0
I 'X,T<Z Q 0
W !!,*7,"Sorry, this time must be ",$S(X:"AFTER",1:"BEFORE")," the time of ",A,": ",Y,!,"Please try again...",! Q 1
;
PREV W !,"You have already selected =>",!
F %=0:0 S %=$O(^TMP("AMER",$J,2,4,%)) Q:'% W ?3,$P(^(%),U,2),!
Q
;
PICK ;
D CHECK^AMER1A I '$D(^AMERADM("B")) S AMERQUIT="" Q
Q:$D(AMERQUIT) ;IHS/OIT/SCR 10/14/09 patch 2 beta1
PQ S B="" I I=1 S B=1
;PQ S B="" ;IHS/OIT/SCR patch 2
S DIR(0)="N",DIR("A")="Select ER patient" S:B DIR("B")=B
D ^DIR I $D(DTOUT)!$D(DUOUT) S X=U E S X=Y
K DIR,Y,DTOUT,DUOUT
I $E(X)=U S AMERQUIT="" Q
I X?1."?" S X="??"
I X="",B'="" S X=1
I X=+X,$D(^TMP("AMER TEMP",$J,X)) S %=$O(^(X,"")) I % S X="`"_% W " ",$P($G(^DPT(%,0)),U)
S DIC="^DPT(",DIC(0)="EQS",DIC("S")="I $D(^AMERADM(Y))"
S AMERI=I D ^DIC S I=AMERI D OUT^AMER
K AMERI,DIC,D,B,X,%
I $D(AMERQUIT) Q
I Y=-1 G PQ
S AMERDFN=+Y
Q
AMER2 ; IHS/ANMC/GIS - ER DISCHARGE DATA COLLECTION ;
+1 ;;3.0;ER VISIT SYSTEM;**1,2,6**;MAR 03, 2009;Build 30
+2 ;
QD1 ; NAME
+1 IF $DATA(AMERDNA)
WRITE !,?5,"***** PROCESS PATIENT WHO LEFT BEFORE VISIT WAS COMPLETED *****",!!,*7
+2 DO PICK
KILL ^TMP("AMER TEMP",$JOB)
IF $DATA(AMERQUIT)
QUIT
+3 DO UTL^AMER0(AMERDFN)
SET (X,Y)=AMERDFN
+4 IF $DATA(AMERDNA)
SET AMERRUN=12
QUIT
+5 SET AMERRUN=19
+6 QUIT
+7 ;
QD2 ; INJURY
+1 ;
+2 ;Pull information from Dashboard if populated
+3 NEW AMERPCC,INJ
+4 SET AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
IF AMERPCC]""
IF $TEXT(INJURY^BEDDINJ)]""
Begin DoDot:1
+5 NEW INJ,EXEC
+6 ;
+7 ;Make the dashboard retrieval call
+8 SET EXEC="D INJURY^BEDDINJ(AMERPCC,.INJ)"
XECUTE EXEC
+9 ;
+10 ;If injury not set quit
+11 IF $GET(INJ("ISINJ"))'="YES"
QUIT
+12 ;
+13 ;Fill in information
+14 ;Is Injury
SET ^TMP("AMER",$JOB,2,2)=1
+15 ;Injury Town
SET ^TMP("AMER",$JOB,2,31)=$GET(INJ("INLOC"))
+16 ;Injury Date/Time
SET ^TMP("AMER",$JOB,2,32)=$GET(INJ("INDAT"))
+17 ;Injury Cause
SET ^TMP("AMER",$JOB,2,33)=$GET(INJ("ICIEN"))
+18 ;Injury Setting
SET ^TMP("AMER",$JOB,2,34)=$GET(INJ("INSET"))
+19 ;Injury Safety
SET ^TMP("AMER",$JOB,2,35)=$GET(INJ("INJEQ"))
+20 ;Driver Insurance Co
SET ^TMP("AMER",$JOB,2,42)=$GET(INJ("INSCO"))
+21 ;Driver Policy Number
SET ^TMP("AMER",$JOB,2,43)=$GET(INJ("INSPO"))
+22 ;MVC Location
SET ^TMP("AMER",$JOB,2,41)=$GET(INJ("MVLOC"))
+23 ;Work related
SET ^TMP("AMER",$JOB,2,5)=$GET(INJ("WKREL"))
End DoDot:1
+24 ;
+25 SET DIR("B")="NO"
IF $GET(^TMP("AMER",$JOB,2,2))
SET DIR("B")="YES"
+26 SET DIR(0)="YO"
SET DIR("A")="*Was this ER visit caused by an injury"
DO ^DIR
KILL DIR
+27 DO OUT^AMER
+28 ;
+29 ;AMER*3.0*6;Added call to update BEDD
+30 IF Y'["^"
SET INJ=Y
Begin DoDot:1
+31 NEW Y
+32 DO INJ^AMERBEDD("INJ.Injury",INJ)
End DoDot:1
+33 ;
+34 IF Y=U
IF '$DATA(AMEREFLG)
SET AMERFIN=28
SET AMERRUN=27
QUIT
+35 IF 'Y
IF '$GET(^TMP("AMER",$JOB,2,2))
IF $DATA(AMEREFLG)
SET AMERRUN=98
QUIT
+36 IF Y
SET AMERRUN=29
SET AMERFIN=71
QUIT
+37 ; KILL OFF ALL DESCENDENTS
FOR I=32:1:35,41:1:46,51:1:57,61:1:64,70
KILL ^TMP("AMER",$JOB,2,I)
+38 SET AMERRUN=4
+39 QUIT
+40 ;
QD5 ; WORK RELATED
+1 SET DIR("B")="NO"
IF $GET(^TMP("AMER",$JOB,2,5))
SET DIR("B")="YES"
+2 SET DIR(0)="YO"
SET DIR("A")="*Was this ER visit WORK-RELATED"
DO ^DIR
KILL DIR
+3 ;S AMERFIN=27
DO OUT^AMER
IF X=U
IF '$DATA(AMEREFLG)
+4 ;
+5 ;AMER*3.0*6;Added call to update BEDD
+6 NEW INJ
+7 IF Y'["^"
SET INJ=Y
Begin DoDot:1
+8 NEW Y
+9 DO INJ^AMERBEDD("INJ.PtInjury.WrkRel",INJ)
End DoDot:1
+10 KILL INJ
+11 ;
+12 QUIT
QD6 ; ER CONSULTANT NOTIFIED
+1 NEW DIR
+2 SET DIR("B")="NO"
IF $GET(^TMP("AMER",$JOB,2,6))
SET DIR("B")="YES"
+3 SET DIR(0)="YO"
SET DIR("A")="*Was an ER CONSULTANT notified"
DO ^DIR
KILL DIR
+4 DO OUT^AMER
IF X?1."^"
QUIT
+5 IF 'Y
KILL ^TMP("AMER",$JOB,2,7)
SET ^TMP("AMER",$JOB,2,6)=0
SET AMERRUN=9
+6 IF 'Y
IF $DATA(AMEREFLG)
SET AMERRUN=98
+7 IF 'Y
QUIT
+8 SET ^TMP("AMER",$JOB,2,6)=1
+9 QUIT
+10 ;
QD7 ; ER CONSULTANT TYPE
+1 SET AMERRUN=9
+2 NEW AMERSNO,AMERO,AMERDEL,AMERREM,AMERSTOP,DIC,DIR
+3 SET AMERSNO=1
SET AMERO=0
SET AMERREM=0
SET AMERSTOP=""
+4 FOR
SET AMERO=$ORDER(^TMP("AMER",$JOB,2,7,AMERO))
IF 'AMERO
QUIT
SET AMERSNO=AMERSNO+1
+5 FOR
IF AMERSTOP="^"
QUIT
Begin DoDot:1
+6 SET AMERREM=0
+7 SET DIC="^AMER(2.9,"
SET DIC(0)="AMEQ"
SET Y=""
SET DIC("S")="I $P(^(0),U,2)="""""
+8 SET AMEROPT=""
SET DIC("A")="*CONSULTANT SERVICE: "
+9 SET DIC("B")=$PIECE($GET(^TMP("AMER",$JOB,2,7,1)),U,2)
+10 DO ^DIC
+11 IF X=""
IF AMERSNO=1
Begin DoDot:2
+12 SET AMERO=0
+13 SET AMERO=$ORDER(^TMP("AMER",$JOB,2,7,AMERO))
+14 IF AMERO=""
KILL ^TMP("AMER",$JOB,2,7)
DO EN^DDIOL("No ER CONSULTANT notified","","!!")
+15 SET AMERSTOP="^"
+16 QUIT
End DoDot:2
+17 IF X?2."^"
SET DIROUT=""
SET AMERSTOP="^"
+18 IF "^"[$EXTRACT(X)
SET AMERSTOP="^"
SET AMERRUN=9
QUIT
+19 SET ^TMP("AMER",$JOB,2,7,AMERSNO)=Y
+20 SET ^TMP("AMER",$JOB,2,7,AMERSNO,.01)=+Y
+21 SET AMERO=0
+22 FOR
SET AMERO=$ORDER(^TMP("AMER",$JOB,2,7,AMERO))
IF 'AMERO
QUIT
Begin DoDot:2
+23 ;DUPLICATE ENTRY
IF AMERO'=AMERSNO&($PIECE($GET(^TMP("AMER",$JOB,2,7,AMERO)),U,1)=+Y)
Begin DoDot:3
+24 ;WE JUST ADDED A DUPLICATE TO THE TEMP GLOBAL AND WE WANT IT GONE
KILL ^TMP("AMER",$JOB,2,7,AMERSNO)
+25 SET AMERREM=$$REM()
+26 ;IF USER ANSWERS YES, DELETE THE ORIGINAL ENTRY
IF AMERREM
KILL ^TMP("AMER",$JOB,2,7,AMERO)
+27 QUIT
End DoDot:3
+28 QUIT
End DoDot:2
+29 IF AMERREM=1
QUIT
+30 IF $EXTRACT(X)=U
SET AMERQUIT=""
SET AMERRUN=9
QUIT
+31 ;to set time
DO QD8
+32 ;Get name
+33 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
SET AMERSTOP="^"
QUIT
+34 KILL DIC("B")
+35 IF $GET(^TMP("AMER",$JOB,2,7,AMERSNO,.03))
SET DIC("B")=^TMP("AMER",$JOB,2,7,AMERSNO,.03)
+36 SET DIC("A")="*CONSULTANT NAME: "
+37 SET DIC="^VA(200,"
SET DIC(0)="AEQ"
+38 SET DIC("?")="Only active providers can be selected"
+39 ;screening so that only valid PCC providers identified
+40 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+41 DO ^DIC
KILL DIC
+42 ;IHS/OIT/SCR 5/11/09 - REQUIRE CONSULTANT TIME AND NAME OR REMOVE ENTRY
+43 ;I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT S AMERSTOP="^" Q
+44 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<0)
Begin DoDot:2
+45 KILL DUOUT,DTOUT
SET AMERSTOP="^"
+46 KILL ^TMP("AMER",$JOB,2,7,AMERSNO)
+47 DO EN^DDIOL("No Provider Identified!","","!!")
+48 DO EN^DDIOL("Consultant Entry not saved","","!")
+49 QUIT
End DoDot:2
QUIT
+50 IF Y>0
SET ^TMP("AMER",$JOB,2,7,AMERSNO,.03)=+Y
SET ^TMP("AMER",$JOB,2,7,AMERSNO)=$GET(^TMP("AMER",$JOB,2,7,AMERSNO))_"^"_Y
+51 SET DIR("A")="*Was another CONSULTANT notified"
+52 SET DIR(0)="Y"
SET DIR("B")="NO"
+53 DO ^DIR
+54 IF Y=1
Begin DoDot:2
+55 SET AMERSNO=AMERSNO+1
SET AMEROPT=""
SET AMERSTOP=""
+56 FOR
SET AMERO=$ORDER(^TMP("AMER",$JOB,2,7,AMERO))
IF 'AMERO
QUIT
SET AMERSNO=AMERSNO+1
+57 QUIT
End DoDot:2
+58 IF '$TEST
SET AMERSTOP="^"
+59 QUIT
End DoDot:1
+60 ;if there are no ER CONSUTANTS entered, make sure ER CONSULTANT notified field is NO
+61 KILL AMERSNO,AMERO,AMERDEL,AMERREM,AMERSTOP,DIC,DIR
+62 QUIT
+63 ;
QD8 ; ER CONSULTANT TIME
+1 NEW Y,DIR
+2 IF $GET(^TMP("AMER",$JOB,2,7,AMERSNO,.02))
SET Y=^TMP("AMER",$JOB,2,7,AMERSNO,.02)
XECUTE ^DD("DD")
SET DIR("B")=Y
+3 ;S DIR(0)="DO^::ER",DIR("A")="*What time did the patient see this CONSULTANT"
+4 ;IHS/OIT/SCR 050509 Patch 1
SET DIR(0)="D^::ER"
SET DIR("A")="*What time did the patient see this CONSULTANT"
+5 SET DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)"
+6 DO ^DIR
KILL DIR
+7 IF Y
IF $$TCK^AMER2A($GET(^TMP("AMER",$JOB,1,2)),Y,1,"admission")
KILL Y
GOTO QD8
+8 IF Y
IF $$TVAL^AMER2A($GET(^TMP("AMER",$JOB,1,2)),Y,4)
KILL Y
GOTO QD8
+9 IF '$TEST
Begin DoDot:1
+10 SET ^TMP("AMER",$JOB,2,7,AMERSNO,.02)=Y
+11 SET ^TMP("AMER",$JOB,2,7,AMERSNO)=$GET(^TMP("AMER",$JOB,2,7,AMERSNO))_"^"_Y
End DoDot:1
+12 QUIT
+13 ;
REM(AMERO) ;
+1 SET DIR("A")="This consultant type has already been identified. Do you want to remove it"
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 DO ^DIR
+4 IF Y=1
QUIT 1
+5 QUIT 0
+6 ;
TCK(Z,T,X,A) ; TIME CHECK WHERE Z=TIME,T=COMPARISON TIME,X=1:AFTER,X=0:BEFORE AND A=NARRATIVE
+1 NEW %,Y
+2 IF $GET(Z)=""!($GET(A)="")
QUIT ""
+3 SET Y=Z
XECUTE ^DD("DD")
+4 IF X
IF T>Z
QUIT 0
+5 IF 'X
IF T<Z
QUIT 0
+6 WRITE !!,*7,"Sorry, this time must be ",$SELECT(X:"AFTER",1:"BEFORE")," the time of ",A,": ",Y,!,"Please try again...",!
QUIT 1
+7 ;
PREV WRITE !,"You have already selected =>",!
+1 FOR %=0:0
SET %=$ORDER(^TMP("AMER",$JOB,2,4,%))
IF '%
QUIT
WRITE ?3,$PIECE(^(%),U,2),!
+2 QUIT
+3 ;
PICK ;
+1 DO CHECK^AMER1A
IF '$DATA(^AMERADM("B"))
SET AMERQUIT=""
QUIT
+2 ;IHS/OIT/SCR 10/14/09 patch 2 beta1
IF $DATA(AMERQUIT)
QUIT
PQ SET B=""
IF I=1
SET B=1
+1 ;PQ S B="" ;IHS/OIT/SCR patch 2
+2 SET DIR(0)="N"
SET DIR("A")="Select ER patient"
IF B
SET DIR("B")=B
+3 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET X=U
IF '$TEST
SET X=Y
+4 KILL DIR,Y,DTOUT,DUOUT
+5 IF $EXTRACT(X)=U
SET AMERQUIT=""
QUIT
+6 IF X?1."?"
SET X="??"
+7 IF X=""
IF B'=""
SET X=1
+8 IF X=+X
IF $DATA(^TMP("AMER TEMP",$JOB,X))
SET %=$ORDER(^(X,""))
IF %
SET X="`"_%
WRITE " ",$PIECE($GET(^DPT(%,0)),U)
+9 SET DIC="^DPT("
SET DIC(0)="EQS"
SET DIC("S")="I $D(^AMERADM(Y))"
+10 SET AMERI=I
DO ^DIC
SET I=AMERI
DO OUT^AMER
+11 KILL AMERI,DIC,D,B,X,%
+12 IF $DATA(AMERQUIT)
QUIT
+13 IF Y=-1
GOTO PQ
+14 SET AMERDFN=+Y
+15 QUIT
