AMERSAV1 ; IHS/ANMC/GIS - PUT ENTRY IN ER VISIT FILE ;
;;3.0;ER VISIT SYSTEM;**6**;MAR 03, 2009;Build 30
;
RUN() ; EP from AMERSAVE
D COMP
D TRANS ; HER TRANSFER FIELDS
S AMERDA=$$DIC(AMERDR(.01)) I 'AMERDA Q 0
F AMERX=1,1.1,2,2.1,12 S %=$G(AMERDR(AMERX)) I %]"" D DIE(AMERDA,%)
; Save identified "clinic" into ER VISIT
F AMERX=2:1:7 S %=$G(AMERDRI(AMERX)) I %]"" D DIE(AMERDA,%) ; INJURY INFO
;IHS/OIT/SCR 12/15/08 - update ER VISIT FILE with DATE LAST UPDATED (NOW)
D TIMESTMP(AMERDA)
D MULT(AMERDA)
D KILL
D EXIT
Q AMERDA
;
EXIT K ZTRTN,ZTIO,ZTDESC,ZTSAVE,AMERDR,ZTDTH,AMERX
K AMERDRI
Q
COMP ; COMPUTED FIELDS
C0 ; REVOLVING DOOR
N X,Y,Z,%,%H,%T,%Y,AMERDFN S AMERDFN=+$P(AMERDR(1),".02////",2)
S Z=AMERDR(.01)
S %=0 F X=0:0 S X=$O(^AMERVSIT("AC",AMERDFN,X)) Q:'X S Y=+^AMERVSIT(X,0) I Y>%,Y'>Z S %=Y
I '% G C1
S %=$$DT^AMERSAV1(Z,%,"D")
I %<366 S AMERDR(2)=AMERDR(2)_";8.2////"_%
C1 ; INJURY TRANSPORT LAG
S X=$$VAL^AMERSAV1("QD32",3) I 'X G C2
S %=$$DT(Z,X,"M"),AMERDR(2)=AMERDR(2)_";8.1////"_%
C2 ; DOC WAIT
S X=$$VAL("QD25",12) I 'X G C3
S %=$$DT(X,Z,"M"),AMERDR(12)=AMERDR(12)_";12.3////"_%
C3 ; TRIAGE WAIT
S X=$$VAL("QD24",12) I 'X G C4
S %=$$DT(X,Z,"M"),AMERDR(12)=AMERDR(12)_";12.4////"_%
C4 ; VISIT DURATION
S X=$$VAL("QD19",2) I 'X G CEXIT
S %=$$DT(X,Z,"M"),AMERDR(12)=AMERDR(12)_";12.5////"_%
CEXIT K A,B,C,E,X,%,%H,Z
Q
;
KILL I $D(ZTQUEUED) S ZTREQ="@"
Q
;
DIC(X) ; GIVEN A ADMISSION TIMESTAMP, CREATE AN ENTRY IN THE ER VISIT FILE AND RETURN THE IEN
I '$G(X) Q ""
N Y,DIC
S DIC="^AMERVSIT(",DIC(0)="L",DIADD=1
K DD,DO
D FILE^DICN
I Y=-1 Q ""
Q +Y
;
DIE(DA,DR) ; GIVEN AN ENTRY NUMBER AND A DR STRING, EDIT THE ER VISIT FILE
N X,Y,%
N D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ
S DIE="^AMERVSIT("
DIE1 L +^AMERVSIT:3 E Q
D ^DIE
L -^AMERVSIT
Q
;
MULT(AMERDA) ; SUBENTRIES
N DA,DIC,X,Y,AMERX,AMERI,AMERY,AMERY2,DR,DIE,D,D0,DICR,DIG,DIH,DIV,DIU,DIW,DQ
S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),4,",DIC(0)="L",DIC("P")=$P(^DD(9009080,4,0),U,2) ; PROCEDURES
F AMERI=1:1 S AMERX=$P($G(AMERDR(4)),U,AMERI) Q:AMERX="" S X="`"_AMERX D ^DIC
S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),5,",DIC(0)="L",DIC("P")=$P(^DD(9009080,5,0),U,2) ; DIAGNOSES
F AMERI=1:1 S AMERX=$P($G(AMERDR(6)),U,AMERI) Q:AMERX="" D
.S X="`"_AMERX
.D ^DIC
.S %=$G(AMERDR(6,AMERI)) I %]""
.S DIE=DIC,DA=+Y,DR="1////"_$E(%,1,80)
.D ^DIE
S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),9,",DIC(0)="L",DIC("P")=$P(^DD(9009080,9,0),U,2) ; PT ED TOPICS
F AMERI=1:1 S AMERX=$P($G(AMERDR(5)),U,AMERI) Q:AMERX="" S X="`"_AMERX D ^DIC
S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),19,",DIC(0)="LN",DIC("P")=$P(^DD(9009080,19,0),U,2) ; ER CONSULTANTS
F AMERI=1:1 S AMERX=$P($G(AMERDR(3)),U,AMERI) Q:AMERX="" D
.S X="`"_AMERX
.D ^DIC Q:Y=-1
.S AMERY=$G(AMERDR(3,AMERI,.02)),AMERY2=$G(AMERDR(3,AMERI,.03))
.S DIE=DIC,DA=+Y,DR=".02////"_AMERY_";.03////"_AMERY2
.D DIE1
S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),18,",DIC(0)="L",DIC("P")=$P(^DD(9009080,18,0),U,2) ; HER TRANSFER FACILITIES
F AMERI=1:1 S AMERX=$P($G(AMERDR(18)),U,AMERI) Q:AMERX="" D
. S X=+AMERX,AMERY=$P(AMERX,";",2)
. D ^DIC I Y=-1 Q
. S DIE=DIC,DA=+Y,DR=".02////"_AMERY
. D DIE1
Q
;
DT(X,Y,T) ; EP - ENTRY POINT FROM AMERFIX ;TIME DIFFERENCE
; X=T2,Y=T1,T="D":DAYS,T="M":MINUTES
I '$G(X)!('$G(Y)) Q ""
I $G(T)="" S T="M"
N %,A,B,C,E,%T,%H,%Y
D H^%DTC S A=+%H,B=%T,X=Y
D H^%DTC S C=+%H,E=%T
I E>B S B=B+86400,A=A-1
S %=((A-C)*86400)+(B-E)
I T="M" S %=%\60
E S %=%\86400
Q %
;
VAL(Q,N) ; EP - ENTRY POINT THIS ROUTINE
; GETS A NUMERIC/DATE VALUE FROM THE DR STRING
N %,X
S %=$O(^AMER(2.3,"B",Q,0)) I '% Q ""
S %=$G(^AMER(2.3,%,0)),%=$P(%,U,5) I '% Q ""
I $P(Q,"QD",2)>30 S X=+$P($G(AMERDRI(N)),(%_"////"),2) Q X
S X=+$P(AMERDR(N),(%_"////"),2)
Q X
;
INJ ; EP - ENTRY POINT CALLED BY AMERSAV ;INJURY ENTRIES
N G,X,Y,Z,%,F,N,V
S G="AMERDRI(N)",X=30
F S X=$O(^TMP("AMER",$J,2,X)) Q:'X S V=^(X) I V]"" D
. ;
. ;AMER*3.0*6;No longer convert to ICD - Already done
. ;I X="33" S V=$G(^AMER(3,+V,"ICD")) I V="" Q ; CONVERT CAUSE OF INJURY OPTION TO ICD CODE
. S Y="QD"_X,Z=$O(^AMER(2.3,"B",Y,0)) I Y="" Q
. S N=X\10,F=$P($G(^AMER(2.3,Z,0)),U,5) I 'F Q
. S %=$G(@G) I %]"" S %=%_";"
. S %=%_F_"////"_V,@G=%
. Q
;
Q
;
TRANS ; HER TRANSFER FIELDS
N %,STG S STG=""
S %=+$P($G(AMERDR(1)),"17.2////",2)
I % S STG=%_";"_"A"
S %=+$P($G(AMERDR(2)),"6.6////",2)
I %,STG'="" S STG=STG_U
I % S STG=STG_%_";"_"D"
S AMERDR(18)=STG
Q
TIMESTMP(AMERIEN) ;UPDATE 'DATE LAST MODIFIED' IN ER VISIT FILE WITH CURRENT TIME
;IHS/SCR/OIT 12/15/08 - ADDED FUNCTION TO STAMP A MODIFIED ER VISIT WITH CURRENT TIME
N X,Y,%
N D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ,DA
S DA=AMERIEN
D NOW^%DTC
S DR="12.6///"_%
S DIE="^AMERVSIT("
L +^AMERVSIT(AMERIEN):3 E Q
D ^DIE
L -^AMERVSIT(AMERIEN)
K DIE,DA,DR
Q
AMERSAV1 ; IHS/ANMC/GIS - PUT ENTRY IN ER VISIT FILE ;
+1 ;;3.0;ER VISIT SYSTEM;**6**;MAR 03, 2009;Build 30
+2 ;
RUN() ; EP from AMERSAVE
+1 DO COMP
+2 ; HER TRANSFER FIELDS
DO TRANS
+3 SET AMERDA=$$DIC(AMERDR(.01))
IF 'AMERDA
QUIT 0
+4 FOR AMERX=1,1.1,2,2.1,12
SET %=$GET(AMERDR(AMERX))
IF %]""
DO DIE(AMERDA,%)
+5 ; Save identified "clinic" into ER VISIT
+6 ; INJURY INFO
FOR AMERX=2:1:7
SET %=$GET(AMERDRI(AMERX))
IF %]""
DO DIE(AMERDA,%)
+7 ;IHS/OIT/SCR 12/15/08 - update ER VISIT FILE with DATE LAST UPDATED (NOW)
+8 DO TIMESTMP(AMERDA)
+9 DO MULT(AMERDA)
+10 DO KILL
+11 DO EXIT
+12 QUIT AMERDA
+13 ;
EXIT KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,AMERDR,ZTDTH,AMERX
+1 KILL AMERDRI
+2 QUIT
COMP ; COMPUTED FIELDS
C0 ; REVOLVING DOOR
+1 NEW X,Y,Z,%,%H,%T,%Y,AMERDFN
SET AMERDFN=+$PIECE(AMERDR(1),".02////",2)
+2 SET Z=AMERDR(.01)
+3 SET %=0
FOR X=0:0
SET X=$ORDER(^AMERVSIT("AC",AMERDFN,X))
IF 'X
QUIT
SET Y=+^AMERVSIT(X,0)
IF Y>%
IF Y'>Z
SET %=Y
+4 IF '%
GOTO C1
+5 SET %=$$DT^AMERSAV1(Z,%,"D")
+6 IF %<366
SET AMERDR(2)=AMERDR(2)_";8.2////"_%
C1 ; INJURY TRANSPORT LAG
+1 SET X=$$VAL^AMERSAV1("QD32",3)
IF 'X
GOTO C2
+2 SET %=$$DT(Z,X,"M")
SET AMERDR(2)=AMERDR(2)_";8.1////"_%
C2 ; DOC WAIT
+1 SET X=$$VAL("QD25",12)
IF 'X
GOTO C3
+2 SET %=$$DT(X,Z,"M")
SET AMERDR(12)=AMERDR(12)_";12.3////"_%
C3 ; TRIAGE WAIT
+1 SET X=$$VAL("QD24",12)
IF 'X
GOTO C4
+2 SET %=$$DT(X,Z,"M")
SET AMERDR(12)=AMERDR(12)_";12.4////"_%
C4 ; VISIT DURATION
+1 SET X=$$VAL("QD19",2)
IF 'X
GOTO CEXIT
+2 SET %=$$DT(X,Z,"M")
SET AMERDR(12)=AMERDR(12)_";12.5////"_%
CEXIT KILL A,B,C,E,X,%,%H,Z
+1 QUIT
+2 ;
KILL IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
+2 ;
DIC(X) ; GIVEN A ADMISSION TIMESTAMP, CREATE AN ENTRY IN THE ER VISIT FILE AND RETURN THE IEN
+1 IF '$GET(X)
QUIT ""
+2 NEW Y,DIC
+3 SET DIC="^AMERVSIT("
SET DIC(0)="L"
SET DIADD=1
+4 KILL DD,DO
+5 DO FILE^DICN
+6 IF Y=-1
QUIT ""
+7 QUIT +Y
+8 ;
DIE(DA,DR) ; GIVEN AN ENTRY NUMBER AND A DR STRING, EDIT THE ER VISIT FILE
+1 NEW X,Y,%
+2 NEW D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ
+3 SET DIE="^AMERVSIT("
DIE1 LOCK +^AMERVSIT:3
IF '$TEST
QUIT
+1 DO ^DIE
+2 LOCK -^AMERVSIT
+3 QUIT
+4 ;
MULT(AMERDA) ; SUBENTRIES
+1 NEW DA,DIC,X,Y,AMERX,AMERI,AMERY,AMERY2,DR,DIE,D,D0,DICR,DIG,DIH,DIV,DIU,DIW,DQ
+2 ; PROCEDURES
SET DA(1)=AMERDA
SET DIC="^AMERVSIT(DA(1),4,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009080,4,0),U,2)
+3 FOR AMERI=1:1
SET AMERX=$PIECE($GET(AMERDR(4)),U,AMERI)
IF AMERX=""
QUIT
SET X="`"_AMERX
DO ^DIC
+4 ; DIAGNOSES
SET DA(1)=AMERDA
SET DIC="^AMERVSIT(DA(1),5,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009080,5,0),U,2)
+5 FOR AMERI=1:1
SET AMERX=$PIECE($GET(AMERDR(6)),U,AMERI)
IF AMERX=""
QUIT
Begin DoDot:1
+6 SET X="`"_AMERX
+7 DO ^DIC
+8 SET %=$GET(AMERDR(6,AMERI))
IF %]""
+9 SET DIE=DIC
SET DA=+Y
SET DR="1////"_$EXTRACT(%,1,80)
+10 DO ^DIE
End DoDot:1
+11 ; PT ED TOPICS
SET DA(1)=AMERDA
SET DIC="^AMERVSIT(DA(1),9,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009080,9,0),U,2)
+12 FOR AMERI=1:1
SET AMERX=$PIECE($GET(AMERDR(5)),U,AMERI)
IF AMERX=""
QUIT
SET X="`"_AMERX
DO ^DIC
+13 ; ER CONSULTANTS
SET DA(1)=AMERDA
SET DIC="^AMERVSIT(DA(1),19,"
SET DIC(0)="LN"
SET DIC("P")=$PIECE(^DD(9009080,19,0),U,2)
+14 FOR AMERI=1:1
SET AMERX=$PIECE($GET(AMERDR(3)),U,AMERI)
IF AMERX=""
QUIT
Begin DoDot:1
+15 SET X="`"_AMERX
+16 DO ^DIC
IF Y=-1
QUIT
+17 SET AMERY=$GET(AMERDR(3,AMERI,.02))
SET AMERY2=$GET(AMERDR(3,AMERI,.03))
+18 SET DIE=DIC
SET DA=+Y
SET DR=".02////"_AMERY_";.03////"_AMERY2
+19 DO DIE1
End DoDot:1
+20 ; HER TRANSFER FACILITIES
SET DA(1)=AMERDA
SET DIC="^AMERVSIT(DA(1),18,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009080,18,0),U,2)
+21 FOR AMERI=1:1
SET AMERX=$PIECE($GET(AMERDR(18)),U,AMERI)
IF AMERX=""
QUIT
Begin DoDot:1
+22 SET X=+AMERX
SET AMERY=$PIECE(AMERX,";",2)
+23 DO ^DIC
IF Y=-1
QUIT
+24 SET DIE=DIC
SET DA=+Y
SET DR=".02////"_AMERY
+25 DO DIE1
End DoDot:1
+26 QUIT
+27 ;
DT(X,Y,T) ; EP - ENTRY POINT FROM AMERFIX ;TIME DIFFERENCE
+1 ; X=T2,Y=T1,T="D":DAYS,T="M":MINUTES
+2 IF '$GET(X)!('$GET(Y))
QUIT ""
+3 IF $GET(T)=""
SET T="M"
+4 NEW %,A,B,C,E,%T,%H,%Y
+5 DO H^%DTC
SET A=+%H
SET B=%T
SET X=Y
+6 DO H^%DTC
SET C=+%H
SET E=%T
+7 IF E>B
SET B=B+86400
SET A=A-1
+8 SET %=((A-C)*86400)+(B-E)
+9 IF T="M"
SET %=%\60
+10 IF '$TEST
SET %=%\86400
+11 QUIT %
+12 ;
VAL(Q,N) ; EP - ENTRY POINT THIS ROUTINE
+1 ; GETS A NUMERIC/DATE VALUE FROM THE DR STRING
+2 NEW %,X
+3 SET %=$ORDER(^AMER(2.3,"B",Q,0))
IF '%
QUIT ""
+4 SET %=$GET(^AMER(2.3,%,0))
SET %=$PIECE(%,U,5)
IF '%
QUIT ""
+5 IF $PIECE(Q,"QD",2)>30
SET X=+$PIECE($GET(AMERDRI(N)),(%_"////"),2)
QUIT X
+6 SET X=+$PIECE(AMERDR(N),(%_"////"),2)
+7 QUIT X
+8 ;
INJ ; EP - ENTRY POINT CALLED BY AMERSAV ;INJURY ENTRIES
+1 NEW G,X,Y,Z,%,F,N,V
+2 SET G="AMERDRI(N)"
SET X=30
+3 FOR
SET X=$ORDER(^TMP("AMER",$JOB,2,X))
IF 'X
QUIT
SET V=^(X)
IF V]""
Begin DoDot:1
+4 ;
+5 ;AMER*3.0*6;No longer convert to ICD - Already done
+6 ;I X="33" S V=$G(^AMER(3,+V,"ICD")) I V="" Q ; CONVERT CAUSE OF INJURY OPTION TO ICD CODE
+7 SET Y="QD"_X
SET Z=$ORDER(^AMER(2.3,"B",Y,0))
IF Y=""
QUIT
+8 SET N=X\10
SET F=$PIECE($GET(^AMER(2.3,Z,0)),U,5)
IF 'F
QUIT
+9 SET %=$GET(@G)
IF %]""
SET %=%_";"
+10 SET %=%_F_"////"_V
SET @G=%
+11 QUIT
End DoDot:1
+12 ;
+13 QUIT
+14 ;
TRANS ; HER TRANSFER FIELDS
+1 NEW %,STG
SET STG=""
+2 SET %=+$PIECE($GET(AMERDR(1)),"17.2////",2)
+3 IF %
SET STG=%_";"_"A"
+4 SET %=+$PIECE($GET(AMERDR(2)),"6.6////",2)
+5 IF %
IF STG'=""
SET STG=STG_U
+6 IF %
SET STG=STG_%_";"_"D"
+7 SET AMERDR(18)=STG
+8 QUIT
TIMESTMP(AMERIEN) ;UPDATE 'DATE LAST MODIFIED' IN ER VISIT FILE WITH CURRENT TIME
+1 ;IHS/SCR/OIT 12/15/08 - ADDED FUNCTION TO STAMP A MODIFIED ER VISIT WITH CURRENT TIME
+2 NEW X,Y,%
+3 NEW D,D0,DI,DIC,DICR,DIE,DIG,DIH,DIV,DIU,DIW,DQ,DA
+4 SET DA=AMERIEN
+5 DO NOW^%DTC
+6 SET DR="12.6///"_%
+7 SET DIE="^AMERVSIT("
+8 LOCK +^AMERVSIT(AMERIEN):3
IF '$TEST
QUIT
+9 DO ^DIE
+10 LOCK -^AMERVSIT(AMERIEN)
+11 KILL DIE,DA,DR
+12 QUIT
