AMER0 ; IHS/ANMC/GIS - AMER SUBROUTINE ;
;;3.0;ER VISIT SYSTEM;**1,2,5,8**;MAR 03, 2009;Build 23
;
;AMER*3.0*8;Moved presenting complaint from field 8 to field 23
SAVE N AMERPCMP S %=$$STG^AMER0(.AMERPCMP)
;N AMERADM,AMERPCC S AMERADM=U_"AMERADM"
N AMERADM,AMERPCC,AMERDA,AMERTIME ;IHS/OIT/SCR 05/19/09
S AMERADM=U_"AMERADM"
I $D(AMERDR("VISIT")) S $P(%,U,12)=AMERDR("VISIT") K AMERDR("VISIT")
S AMERDFN=^TMP("AMER",$J,1,1),Y=$G(^AUPNPAT(AMERDFN,41,DUZ(2),0)),$P(%,U,9)=$P(Y,U,2)
S $P(%,U,5)=$P(^DPT(AMERDFN,0),U,2)
S $P(%,U,11)=DUZ,$P(%,U,8)=$P(^DPT(AMERDFN,0),U,3),AMERSTG=%
I $D(^AMERADM(AMERDFN)) D SETADM(AMERSTG,AMERPCMP) D TRF(AMERDFN) Q
S DIC="^AMERADM(",DIC(0)="L",X=AMERDFN,DINUM=X
K DD,DO
D FILE^DICN K DIC I Y=-1 Q
S @AMERADM@(+Y,0)=AMERSTG
;
;AMER*3.0*8;Save new presenting complaint
S @AMERADM@(+Y,23)=$G(AMERPCMP)
;
I $G(^TMP("AMER",$J,1,6)) D TRF(+Y) ; TRANSFER SEQUENCE
S AMERDA=+Y ;IHS/OIT/SCRT 05/19/09 patch 1
S AMERTIME=$G(^TMP("AMER",$J,1,2))
I AMERTIME'="" D
.;if the LOCATION is not set up for scheduling create create a PCC VISIT through ERS PCC interface $$VISIT^AMPERPCC(AMERDFN,AMERTIME)
.;IHS/OIT/SCR 05/19/09 no scheduling, no visit - commented out next line
.;I $G(^AMER(2.5,DUZ(2),"SD"))="" S AMERPCC=$$VISIT^AMERPCC(AMERDFN,AMERTIME)
.; if the LOCATION is set up for scheduling create a PCC VISIT through ERS interface CHECKIN^AMERBSDU(AMERDFN,AMERTIME)
.I $G(^AMER(2.5,DUZ(2),"SD"))'="" S AMERPCC=$$ERCHCKIN^AMERBSDU(AMERDFN,AMERTIME)
.I AMERPCC>0 D
..D SAVPCCA^AMERPCC(AMERPCC,AMERDFN)
..D VISITIN^AMERPCC(AMERDFN,AMERPCC) ;update VISIT file if it exists
..;SAVE THE PCC VISIT IEN TO A NEW NODE IN THE TEMP FILE SO IT CAN BE TRANSFERED TO ER VISIT FILE later
..S ^TMP("AMER",$J,4)=AMERPCC
..;AMER*3.0*8;Create V EMERGENCY VISIT RECORD entry
.. D VER^AMERVER(AMERDFN,AMERPCC)
..Q
.;IHS/OIT/SCR 051909 patch 1 Don't save info if no PCC visit has been located
.;I AMERPCC<0 D ;IHS/OIT/SCR patch 2 replaced by next line
.I AMERPCC<=0 D
..S DIK="^AMERADM(",DA=AMERDA
..D ^DIK
..D EN^DDIOL("Please re-enter data with a unique appointment time","","!")
..D EN^DDIOL("DATA NOT SAVED!!","","!!")
..S AMERQUIT=1
..Q
.Q
Q
;
PAT ; ENTRY POINT TO VIEW A SINGLE ENTRY FROM THE ER LOG
N AMERDA,AMERPCC
S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Enter name, DOB or chart number: "
D ^DIC K DIC
I $D(DUOUT)!($D(DTOUT)) K DTOUT,DUOUT S AMERQUIT="" G PEXIT
I Y=-1 G PEXIT
W !! S DIC="^AMERVSIT(",DIC(0)="EQ",D="AC",X=+Y
D IX^DIC K DIC
I $D(DUOUT)!($D(DTOUT)) K DTOUT,DUOUT S AMERQUIT="" G PEXIT
I Y=-1 G PEXIT
;IHS/OIT/SCR 01/09/09 SYNCH THIS VISIT WITH WHAT IS IN PCC
S AMERDA=+Y
S AMERPCC=$$FINDVSIT^AMERPCC(AMERDA)
;
;AMER*3.0*5
D LOG^AMERBUSA("P","Q","AMER0","AMER: Printed ER Visit","^"_AMERPCC)
;
I (AMERPCC>0) D
.D SYNCHERA^AMERERS(AMERDA,AMERPCC) ;SYNCH ADMISSION IFO
.D SYNCHERX^AMERERS(AMERDA,AMERPCC) ;SYNCH DIAG INFO
.D SYNCHERD^AMERERS(AMERDA,AMERPCC) ;SYNCH PRIMARY PROVIDER INFO
.D TIMESTMP^AMERSAV1(AMERDA)
.W !,"FINISHED SYNCHING ERS WITH CURRENT PCC DATA" ;IHS/OIT/SCR 05/29/09 patch 1
.Q
S AMERPAT=$P($G(^AMERVSIT(AMERDA,0)),U,2)
D:AMERPAT>0 SYNCHERP^AMERERS(AMERPAT,AMERDA)
;IHS/OIT/SCR 01/09/09 END SYNCH THIS VISIT WITH WHAT IS IN PCC
;S DIC="^AMERVSIT(",BY="NUMBER",(FR,TO)=+Y,FLDS="[AMER DETAIL"
S DIC="^AMERVSIT(",BY="NUMBER",(FR,TO)=AMERDA,FLDS="[AMER DETAIL"
S DHD=$$AMERDHD^AMERREPT("ER LOG ENTRY FOR SINGLE PATIENT","","")
D EN1^DIP
I $G(IOST)["C-" S DIR(0)="E" D ^DIR
PEXIT K Y,X,AUPNDAYS,AUPNPAT,AUPNDOB,AUPNDOD,DA,DIC,DIJ,DISYS,DK,DP,AUPNSEX
K AGE,SSN,SEX,DO,POP
Q
;
CAT(X) ; EP FROM MULTIPLE AMER ROUTINES
; GIVEN AN ER CATEGORY, RETURN ITS IEN
N DIC,Y
S DIC(0)="",DIC="^AMER(2," D ^DIC
Q +Y
;
OPT(X,C) ; ENTRY POINT FROM AMER1
; GIVEN A CATEGORY AND OPTION NAME, RETURN OPTION IEN
N DIC,Y
S DIC(0)="",DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0(C)
D ^DIC
Q +Y
;
;AMER*3.0*8;Moved presenting complaint into 23 (leave in field 8 for compatibility)
STG(AMERPCMP) ; EP FROM SAVE^AMER0
S AMERPCMP=$G(^TMP("AMER",$J,1,3)) ;AMER*3.0*8
;
; CONVERT ^TMP VALUES TO A '^' DELIMITED STRING
N X,Y,Z,%,I,N,A S A=""
S X="QA" F S X=$O(^AMER(2.3,"B",X)) Q:$E(X,1,2)'="QA" S %=$P(X,"QA",2) D
. I (%<6!(%>9)) S Y=^AMER(2.3,$O(^AMER(2.3,"B",X,0)),0) D
.. S Z=$P(Y,U,4),N=$P(Y,U,3) I Z=""!(N="") Q
.. S %=$G(^DD(9009081,Z,0)),I=$P(%,U,4),I=$P(I,";",2) I 'I Q
.. S %=$G(^TMP("AMER",$J,1,N)) Q:%="" I %?1.N1"^"1.E S %=+%
.. ;
.. ;AMER*3.0*8;Backwards compatible for BEDD until BEDD*2.0*1 gets installed
.. ;Need to keep saving in original field until BEDD code to use new field is loaded
.. I $P(X,"QA",2)=3 D Q
... I $T(NEW^BEDDUTW)="" Q ;Not using BEDD
... I $T(XML^BEDD2X01)]"" Q ;Already installed, don't save
... S $P(A,U,10)=%
.. S $P(A,U,I)=%
Q A
;
TEST W $$STG Q
;
UTL(E) ; ENTRY POINT FROM AMER
; CONVERT ADMISSION FILE ENTRY BACK TO TMP GLOBALS
N X,Y,Z,%,I,N,S
S X="QA" F S X=$O(^AMER(2.3,"B",X)) Q:$E(X,1,2)'="QA" S Y=$G(^AMER(2.3,$O(^(X,0)),0)) D
. S Z=$P(Y,U,4),N=$P(Y,U,3)
. S %=$G(^DD(9009081,+$G(Z),0)),%=$P(%,U,4)
. S S=+%
. S I=$P(%,";",2) I 'I,I'["E1," Q
. I I S %=$P($G(^AMERADM(E,S)),U,I)
. I 'I S %=$G(^AMERADM(E,S))
. I %="" Q
. S ^TMP("AMER",$J,1,N)=%
. Q
;
;AMER*3.0*8;Switched complaint fields
I $G(^AMERADM(E,23))]"" S ^TMP("AMER",$J,3,1)=$G(^AMERADM(E,23))
;
Q
;
TRF(DA) ; DR STRINGS RELATED TO TRANSFER
S A=""
F I=1:1:4 S %=+$G(^TMP("AMER",$J,1,(I+5))) S $P(A,U,I)=%
S @AMERADM@(DA,2)=A
Q
;
N X,Y,Z,N,A,%,DIE,DIC,DR,D0,D,DI,DQ,DTOUT,D1,DQ,DO,DTO
S DIE="^AMERADM("
S Z=20 F S Z=$O(^TMP("AMER",$J,1,Z)) Q:'Z S V=^(Z) I V]"" S X=$O(^AMER(2.3,"B",("QA"_Z),0)) Q:'X S A=$G(^AMER(2.3,X,0)) I A]"" D
. S %=$P(A,U,4) I %="" Q
. S DR=%_"////"_V
. D ^DIE
. Q
Q
;
SETADM(AMERSTG,AMERPCMP) ;
N DIE,AMERDFN,AMERDOB,AMERCHRT,AMERSEX,AMERPCC,AMERVTYP,AMERTRNS,AMERCMPL
N AMERTRGN,AMERTRGP,AMERTRTM,AMERPRTM,AMERDUZ,AMERAMBN,AMERAMBB,AMERTRAN
N AMERAMBC,AMERACTY,AMERDR,AMERMOD
;
;AMER*3.0*8;Fixed entries to save in correct location
S AMERDFN=$P(AMERSTG,U,1)
Q:AMERDFN<0
I $D(^AMERADM(AMERDFN)) S AMERDR=""
E S AMERDR=".01///"_AMERDFN
S AMERDOB=$P(AMERSTG,U,8)
I AMERDR="" S AMERDR=AMERDR_".02////"_AMERDOB
E S AMERDR=AMERDR_";.02////"_AMERDOB
S AMERCHRT=$P(AMERSTG,U,9)
S AMERDR=AMERDR_";.03////"_AMERCHRT
S AMERTIME=$P(AMERSTG,U,2)
S AMERDR=AMERDR_";1////"_AMERTIME
S AMERSEX=$P(AMERSTG,U,5)
S AMERDR=AMERDR_";.05////"_AMERSEX
S AMERVTYP=$P(AMERSTG,U,4)
S AMERDR=AMERDR_";3////"_AMERVTYP
;
;S AMERTRNS=$P(AMERSTG,U,6)
;S AMERDR=AMERDR_";14////"_AMERTRNS
S AMERMOD=$P(AMERSTG,U,6)
S AMERDR=AMERDR_";6////"_AMERMOD
;
;AMER*3.0*8;Moved complaint from field 8 to field 23
;S AMERCMPL=$P(AMERSTG,U,10)
;S AMERDR=AMERDR_";8////"_AMERCMPL
S AMERDR=AMERDR_";23////"_AMERPCMP
D
. ;If using BEDD and no patch 1, save in original field
. I $T(NEW^BEDDUTW)="" Q ;Not using BEDD
. I $T(XML^BEDD2X01)]"" Q ;Already installed, don't save
. S AMERDR=AMERDR_";8////"_AMERPCMP
;
S AMERTRGN=$P(AMERSTG,U,19)
S AMERDR=AMERDR_";19////"_AMERTRGN
S AMERTRGP=$P(AMERSTG,U,19)
S AMERDR=AMERDR_";20////"_AMERTRGP
S AMERTRTM=$P(AMERSTG,U,21)
S AMERDR=AMERDR_";21////"_AMERTRTM
S AMERPRTM=$P(AMERSTG,U,22)
S AMERDR=AMERDR_";22////"_AMERPRTM
S AMERDUZ=$P(AMERSTG,U,11)
S AMERDR=AMERDR_";10////"_AMERDUZ
S AMERAMBN=$P(AMERSTG,U,14)
S AMERDR=AMERDR_";12////"_AMERAMBN
S AMERAMBB=$P(AMERSTG,U,15)
S AMERDR=AMERDR_";13////"_AMERAMBB
S AMERTRAN=$P(AMERSTG,U,16)
S AMERDR=AMERDR_";14////"_AMERTRAN
S AMERAMBC=$P(AMERSTG,U,17)
S AMERDR=AMERDR_";15////"_AMERAMBC
S AMERACTY=$P(AMERSTG,U,20)
S AMERDR=AMERDR_";20////"_AMERACTY
S AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
S AMERDR=AMERDR_";1.1////"_AMERPCC
S DIE="^AMERADM(",DA=AMERDFN,DR=AMERDR
L +^FILE(9009081):2
I $T D
.D ^DIE
.L -^FILE(9009081)
.Q
;
;AMER*3.0*8;Update V EMERGENCY VISIT RECORD entry
D VER^AMERVER(AMERDFN,AMERPCC)
;
Q
AMER0 ; IHS/ANMC/GIS - AMER SUBROUTINE ;
+1 ;;3.0;ER VISIT SYSTEM;**1,2,5,8**;MAR 03, 2009;Build 23
+2 ;
+3 ;AMER*3.0*8;Moved presenting complaint from field 8 to field 23
SAVE NEW AMERPCMP
SET %=$$STG^AMER0(.AMERPCMP)
+1 ;N AMERADM,AMERPCC S AMERADM=U_"AMERADM"
+2 ;IHS/OIT/SCR 05/19/09
NEW AMERADM,AMERPCC,AMERDA,AMERTIME
+3 SET AMERADM=U_"AMERADM"
+4 IF $DATA(AMERDR("VISIT"))
SET $PIECE(%,U,12)=AMERDR("VISIT")
KILL AMERDR("VISIT")
+5 SET AMERDFN=^TMP("AMER",$JOB,1,1)
SET Y=$GET(^AUPNPAT(AMERDFN,41,DUZ(2),0))
SET $PIECE(%,U,9)=$PIECE(Y,U,2)
+6 SET $PIECE(%,U,5)=$PIECE(^DPT(AMERDFN,0),U,2)
+7 SET $PIECE(%,U,11)=DUZ
SET $PIECE(%,U,8)=$PIECE(^DPT(AMERDFN,0),U,3)
SET AMERSTG=%
+8 IF $DATA(^AMERADM(AMERDFN))
DO SETADM(AMERSTG,AMERPCMP)
DO TRF(AMERDFN)
QUIT
+9 SET DIC="^AMERADM("
SET DIC(0)="L"
SET X=AMERDFN
SET DINUM=X
+10 KILL DD,DO
+11 DO FILE^DICN
KILL DIC
IF Y=-1
QUIT
+12 SET @AMERADM@(+Y,0)=AMERSTG
+13 ;
+14 ;AMER*3.0*8;Save new presenting complaint
+15 SET @AMERADM@(+Y,23)=$GET(AMERPCMP)
+16 ;
+17 ; TRANSFER SEQUENCE
IF $GET(^TMP("AMER",$JOB,1,6))
DO TRF(+Y)
+18 ;IHS/OIT/SCRT 05/19/09 patch 1
SET AMERDA=+Y
+19 SET AMERTIME=$GET(^TMP("AMER",$JOB,1,2))
+20 IF AMERTIME'=""
Begin DoDot:1
+21 ;if the LOCATION is not set up for scheduling create create a PCC VISIT through ERS PCC interface $$VISIT^AMPERPCC(AMERDFN,AMERTIME)
+22 ;IHS/OIT/SCR 05/19/09 no scheduling, no visit - commented out next line
+23 ;I $G(^AMER(2.5,DUZ(2),"SD"))="" S AMERPCC=$$VISIT^AMERPCC(AMERDFN,AMERTIME)
+24 ; if the LOCATION is set up for scheduling create a PCC VISIT through ERS interface CHECKIN^AMERBSDU(AMERDFN,AMERTIME)
+25 IF $GET(^AMER(2.5,DUZ(2),"SD"))'=""
SET AMERPCC=$$ERCHCKIN^AMERBSDU(AMERDFN,AMERTIME)
+26 IF AMERPCC>0
Begin DoDot:2
+27 DO SAVPCCA^AMERPCC(AMERPCC,AMERDFN)
+28 ;update VISIT file if it exists
DO VISITIN^AMERPCC(AMERDFN,AMERPCC)
+29 ;SAVE THE PCC VISIT IEN TO A NEW NODE IN THE TEMP FILE SO IT CAN BE TRANSFERED TO ER VISIT FILE later
+30 SET ^TMP("AMER",$JOB,4)=AMERPCC
+31 ;AMER*3.0*8;Create V EMERGENCY VISIT RECORD entry
+32 DO VER^AMERVER(AMERDFN,AMERPCC)
+33 QUIT
End DoDot:2
+34 ;IHS/OIT/SCR 051909 patch 1 Don't save info if no PCC visit has been located
+35 ;I AMERPCC<0 D ;IHS/OIT/SCR patch 2 replaced by next line
+36 IF AMERPCC<=0
Begin DoDot:2
+37 SET DIK="^AMERADM("
SET DA=AMERDA
+38 DO ^DIK
+39 DO EN^DDIOL("Please re-enter data with a unique appointment time","","!")
+40 DO EN^DDIOL("DATA NOT SAVED!!","","!!")
+41 SET AMERQUIT=1
+42 QUIT
End DoDot:2
+43 QUIT
End DoDot:1
+44 QUIT
+45 ;
PAT ; ENTRY POINT TO VIEW A SINGLE ENTRY FROM THE ER LOG
+1 NEW AMERDA,AMERPCC
+2 SET DIC="^DPT("
SET DIC(0)="AEQM"
SET DIC("A")="Enter name, DOB or chart number: "
+3 DO ^DIC
KILL DIC
+4 IF $DATA(DUOUT)!($DATA(DTOUT))
KILL DTOUT,DUOUT
SET AMERQUIT=""
GOTO PEXIT
+5 IF Y=-1
GOTO PEXIT
+6 WRITE !!
SET DIC="^AMERVSIT("
SET DIC(0)="EQ"
SET D="AC"
SET X=+Y
+7 DO IX^DIC
KILL DIC
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
KILL DTOUT,DUOUT
SET AMERQUIT=""
GOTO PEXIT
+9 IF Y=-1
GOTO PEXIT
+10 ;IHS/OIT/SCR 01/09/09 SYNCH THIS VISIT WITH WHAT IS IN PCC
+11 SET AMERDA=+Y
+12 SET AMERPCC=$$FINDVSIT^AMERPCC(AMERDA)
+13 ;
+14 ;AMER*3.0*5
+15 DO LOG^AMERBUSA("P","Q","AMER0","AMER: Printed ER Visit","^"_AMERPCC)
+16 ;
+17 IF (AMERPCC>0)
Begin DoDot:1
+18 ;SYNCH ADMISSION IFO
DO SYNCHERA^AMERERS(AMERDA,AMERPCC)
+19 ;SYNCH DIAG INFO
DO SYNCHERX^AMERERS(AMERDA,AMERPCC)
+20 ;SYNCH PRIMARY PROVIDER INFO
DO SYNCHERD^AMERERS(AMERDA,AMERPCC)
+21 DO TIMESTMP^AMERSAV1(AMERDA)
+22 ;IHS/OIT/SCR 05/29/09 patch 1
WRITE !,"FINISHED SYNCHING ERS WITH CURRENT PCC DATA"
+23 QUIT
End DoDot:1
+24 SET AMERPAT=$PIECE($GET(^AMERVSIT(AMERDA,0)),U,2)
+25 IF AMERPAT>0
DO SYNCHERP^AMERERS(AMERPAT,AMERDA)
+26 ;IHS/OIT/SCR 01/09/09 END SYNCH THIS VISIT WITH WHAT IS IN PCC
+27 ;S DIC="^AMERVSIT(",BY="NUMBER",(FR,TO)=+Y,FLDS="[AMER DETAIL"
+28 SET DIC="^AMERVSIT("
SET BY="NUMBER"
SET (FR,TO)=AMERDA
SET FLDS="[AMER DETAIL"
+29 SET DHD=$$AMERDHD^AMERREPT("ER LOG ENTRY FOR SINGLE PATIENT","","")
+30 DO EN1^DIP
+31 IF $GET(IOST)["C-"
SET DIR(0)="E"
DO ^DIR
PEXIT KILL Y,X,AUPNDAYS,AUPNPAT,AUPNDOB,AUPNDOD,DA,DIC,DIJ,DISYS,DK,DP,AUPNSEX
+1 KILL AGE,SSN,SEX,DO,POP
+2 QUIT
+3 ;
CAT(X) ; EP FROM MULTIPLE AMER ROUTINES
+1 ; GIVEN AN ER CATEGORY, RETURN ITS IEN
+2 NEW DIC,Y
+3 SET DIC(0)=""
SET DIC="^AMER(2,"
DO ^DIC
+4 QUIT +Y
+5 ;
OPT(X,C) ; ENTRY POINT FROM AMER1
+1 ; GIVEN A CATEGORY AND OPTION NAME, RETURN OPTION IEN
+2 NEW DIC,Y
+3 SET DIC(0)=""
SET DIC="^AMER(3,"
SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0(C)
+4 DO ^DIC
+5 QUIT +Y
+6 ;
+7 ;AMER*3.0*8;Moved presenting complaint into 23 (leave in field 8 for compatibility)
STG(AMERPCMP) ; EP FROM SAVE^AMER0
+1 ;AMER*3.0*8
SET AMERPCMP=$GET(^TMP("AMER",$JOB,1,3))
+2 ;
+3 ; CONVERT ^TMP VALUES TO A '^' DELIMITED STRING
+4 NEW X,Y,Z,%,I,N,A
SET A=""
+5 SET X="QA"
FOR
SET X=$ORDER(^AMER(2.3,"B",X))
IF $EXTRACT(X,1,2)'="QA"
QUIT
SET %=$PIECE(X,"QA",2)
Begin DoDot:1
+6 IF (%<6!(%>9))
SET Y=^AMER(2.3,$ORDER(^AMER(2.3,"B",X,0)),0)
Begin DoDot:2
+7 SET Z=$PIECE(Y,U,4)
SET N=$PIECE(Y,U,3)
IF Z=""!(N="")
QUIT
+8 SET %=$GET(^DD(9009081,Z,0))
SET I=$PIECE(%,U,4)
SET I=$PIECE(I,";",2)
IF 'I
QUIT
+9 SET %=$GET(^TMP("AMER",$JOB,1,N))
IF %=""
QUIT
IF %?1.N1"^"1.E
SET %=+%
+10 ;
+11 ;AMER*3.0*8;Backwards compatible for BEDD until BEDD*2.0*1 gets installed
+12 ;Need to keep saving in original field until BEDD code to use new field is loaded
+13 IF $PIECE(X,"QA",2)=3
Begin DoDot:3
+14 ;Not using BEDD
IF $TEXT(NEW^BEDDUTW)=""
QUIT
+15 ;Already installed, don't save
IF $TEXT(XML^BEDD2X01)]""
QUIT
+16 SET $PIECE(A,U,10)=%
End DoDot:3
QUIT
+17 SET $PIECE(A,U,I)=%
End DoDot:2
End DoDot:1
+18 QUIT A
+19 ;
TEST WRITE $$STG
QUIT
+1 ;
UTL(E) ; ENTRY POINT FROM AMER
+1 ; CONVERT ADMISSION FILE ENTRY BACK TO TMP GLOBALS
+2 NEW X,Y,Z,%,I,N,S
+3 SET X="QA"
FOR
SET X=$ORDER(^AMER(2.3,"B",X))
IF $EXTRACT(X,1,2)'="QA"
QUIT
SET Y=$GET(^AMER(2.3,$ORDER(^(X,0)),0))
Begin DoDot:1
+4 SET Z=$PIECE(Y,U,4)
SET N=$PIECE(Y,U,3)
+5 SET %=$GET(^DD(9009081,+$GET(Z),0))
SET %=$PIECE(%,U,4)
+6 SET S=+%
+7 SET I=$PIECE(%,";",2)
IF 'I
IF I'["E1,"
QUIT
+8 IF I
SET %=$PIECE($GET(^AMERADM(E,S)),U,I)
+9 IF 'I
SET %=$GET(^AMERADM(E,S))
+10 IF %=""
QUIT
+11 SET ^TMP("AMER",$JOB,1,N)=%
+12 QUIT
End DoDot:1
+13 ;
+14 ;AMER*3.0*8;Switched complaint fields
+15 IF $GET(^AMERADM(E,23))]""
SET ^TMP("AMER",$JOB,3,1)=$GET(^AMERADM(E,23))
+16 ;
+17 QUIT
+18 ;
TRF(DA) ; DR STRINGS RELATED TO TRANSFER
+1 SET A=""
+2 FOR I=1:1:4
SET %=+$GET(^TMP("AMER",$JOB,1,(I+5)))
SET $PIECE(A,U,I)=%
+3 SET @AMERADM@(DA,2)=A
+4 QUIT
+5 ;
+6 NEW X,Y,Z,N,A,%,DIE,DIC,DR,D0,D,DI,DQ,DTOUT,D1,DQ,DO,DTO
+7 SET DIE="^AMERADM("
+8 SET Z=20
FOR
SET Z=$ORDER(^TMP("AMER",$JOB,1,Z))
IF 'Z
QUIT
SET V=^(Z)
IF V]""
SET X=$ORDER(^AMER(2.3,"B",("QA"_Z),0))
IF 'X
QUIT
SET A=$GET(^AMER(2.3,X,0))
IF A]""
Begin DoDot:1
+9 SET %=$PIECE(A,U,4)
IF %=""
QUIT
+10 SET DR=%_"////"_V
+11 DO ^DIE
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
SETADM(AMERSTG,AMERPCMP) ;
+1 NEW DIE,AMERDFN,AMERDOB,AMERCHRT,AMERSEX,AMERPCC,AMERVTYP,AMERTRNS,AMERCMPL
+2 NEW AMERTRGN,AMERTRGP,AMERTRTM,AMERPRTM,AMERDUZ,AMERAMBN,AMERAMBB,AMERTRAN
+3 NEW AMERAMBC,AMERACTY,AMERDR,AMERMOD
+4 ;
+5 ;AMER*3.0*8;Fixed entries to save in correct location
+6 SET AMERDFN=$PIECE(AMERSTG,U,1)
+7 IF AMERDFN<0
QUIT
+8 IF $DATA(^AMERADM(AMERDFN))
SET AMERDR=""
+9 IF '$TEST
SET AMERDR=".01///"_AMERDFN
+10 SET AMERDOB=$PIECE(AMERSTG,U,8)
+11 IF AMERDR=""
SET AMERDR=AMERDR_".02////"_AMERDOB
+12 IF '$TEST
SET AMERDR=AMERDR_";.02////"_AMERDOB
+13 SET AMERCHRT=$PIECE(AMERSTG,U,9)
+14 SET AMERDR=AMERDR_";.03////"_AMERCHRT
+15 SET AMERTIME=$PIECE(AMERSTG,U,2)
+16 SET AMERDR=AMERDR_";1////"_AMERTIME
+17 SET AMERSEX=$PIECE(AMERSTG,U,5)
+18 SET AMERDR=AMERDR_";.05////"_AMERSEX
+19 SET AMERVTYP=$PIECE(AMERSTG,U,4)
+20 SET AMERDR=AMERDR_";3////"_AMERVTYP
+21 ;
+22 ;S AMERTRNS=$P(AMERSTG,U,6)
+23 ;S AMERDR=AMERDR_";14////"_AMERTRNS
+24 SET AMERMOD=$PIECE(AMERSTG,U,6)
+25 SET AMERDR=AMERDR_";6////"_AMERMOD
+26 ;
+27 ;AMER*3.0*8;Moved complaint from field 8 to field 23
+28 ;S AMERCMPL=$P(AMERSTG,U,10)
+29 ;S AMERDR=AMERDR_";8////"_AMERCMPL
+30 SET AMERDR=AMERDR_";23////"_AMERPCMP
+31 Begin DoDot:1
+32 ;If using BEDD and no patch 1, save in original field
+33 ;Not using BEDD
IF $TEXT(NEW^BEDDUTW)=""
QUIT
+34 ;Already installed, don't save
IF $TEXT(XML^BEDD2X01)]""
QUIT
+35 SET AMERDR=AMERDR_";8////"_AMERPCMP
End DoDot:1
+36 ;
+37 SET AMERTRGN=$PIECE(AMERSTG,U,19)
+38 SET AMERDR=AMERDR_";19////"_AMERTRGN
+39 SET AMERTRGP=$PIECE(AMERSTG,U,19)
+40 SET AMERDR=AMERDR_";20////"_AMERTRGP
+41 SET AMERTRTM=$PIECE(AMERSTG,U,21)
+42 SET AMERDR=AMERDR_";21////"_AMERTRTM
+43 SET AMERPRTM=$PIECE(AMERSTG,U,22)
+44 SET AMERDR=AMERDR_";22////"_AMERPRTM
+45 SET AMERDUZ=$PIECE(AMERSTG,U,11)
+46 SET AMERDR=AMERDR_";10////"_AMERDUZ
+47 SET AMERAMBN=$PIECE(AMERSTG,U,14)
+48 SET AMERDR=AMERDR_";12////"_AMERAMBN
+49 SET AMERAMBB=$PIECE(AMERSTG,U,15)
+50 SET AMERDR=AMERDR_";13////"_AMERAMBB
+51 SET AMERTRAN=$PIECE(AMERSTG,U,16)
+52 SET AMERDR=AMERDR_";14////"_AMERTRAN
+53 SET AMERAMBC=$PIECE(AMERSTG,U,17)
+54 SET AMERDR=AMERDR_";15////"_AMERAMBC
+55 SET AMERACTY=$PIECE(AMERSTG,U,20)
+56 SET AMERDR=AMERDR_";20////"_AMERACTY
+57 SET AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
+58 SET AMERDR=AMERDR_";1.1////"_AMERPCC
+59 SET DIE="^AMERADM("
SET DA=AMERDFN
SET DR=AMERDR
+60 LOCK +^FILE(9009081):2
+61 IF $TEST
Begin DoDot:1
+62 DO ^DIE
+63 LOCK -^FILE(9009081)
+64 QUIT
End DoDot:1
+65 ;
+66 ;AMER*3.0*8;Update V EMERGENCY VISIT RECORD entry
+67 DO VER^AMERVER(AMERDFN,AMERPCC)
+68 ;
+69 QUIT
