AMERSAV ; IHS/ANMC/GIS -ISC - FILE INFO IN ER VISIT FILE ;
;;3.0;ER VISIT SYSTEM;**6,7,8**;MAR 03, 2009;Build 23
;
;IHS/OIT/SCR 12/17/08
;This routine is called by AMERD upon discharge of ER
;TMP globals that are initially populated by info in ER ADMIT and now contain OUT info
;are being transfered to the ^AMERVSIT file
RUN ;
; Transfer PCC VISIT ien
S AMERDR(1)=$$DR1("QA")
S AMERDR(1)=AMERDR(1)_";.03////"_$P($G(^AMERADM(AMERDFN,0)),U,3)
S AMERDR(2)=$$DR1("QD")_";.19////"_$G(DUZ)_";10.1////1"
;AMER*3.0*7;Stop updating DX information at this point - now getting pushed from PCC
;S %=$G(^TMP("AMER",$J,2,11,.1)) I %]"" S AMERDR(2)=AMERDR(2)_";5.2////"_+%_";5.3////"_$P($P(%,U,2)," [") ; PRIMARY DIAGNOSIS
S %=$G(^TMP("AMER",$J,2,11,.1)) ;I %]"" S AMERDR(2)=AMERDR(2)_";5.2////"_+%_";5.3////"_$P($P(%,U,2)," [") ; PRIMARY DIAGNOSIS
D INJ^AMERSAV1
D CONSULT
D STUFF(AMERDFN),DRM,KILLADM,TASK
EXIT Q
;
DR1(T) ; MAKES DR STRING FROM TMP GLOBALS. DOES NOT DO SUBFILES
N X,Y,Z,%,I,J,N,A,AMERSTOP S A="",J=1+(T="QD")
S X=T F S X=$O(^AMER(2.3,"B",X)) Q:$E(X,1,2)'=T S Y=$O(^(X,0)) Q:'Y D
.I X="QD5" D XXX
.I T="QD",+$P(X,"QD",2)>30 Q
.I X="QA2" S AMERDR(.01)=$G(^TMP("AMER",$J,1,2)) Q
.S Z=^AMER(2.3,Y,0)
.I $P(Z,U,7) Q
.S N=$P(Z,U,5) I 'N Q
.I X="QA3" S %=$G(^TMP("AMER",$J,1,3)) S:%]"" AMERDR(1.1)=N_"////"_% Q
.;
.;AMER*3.0*6;No longer convert
.;I X="QD33" D Q
.;.S %=$G(^TMP("AMER",$J,2,33)) S:% %=$G(^AMER(3,+%,"ICD")) S:% A=A_";"_N_"////"_% Q
.I X="QD33" S %=$G(^TMP("AMER",$J,2,33)) S:% A=A_";"_N_"////"_% Q
.;
.I X="QD16" S %=$G(^TMP("AMER",$J,2,16)) S:%]"" AMERDR(2.1)=N_"////"_+% Q
.I X]"QD19",X']"QD23" S Y=$E(X,3,4),%=$G(^TMP("AMER",$J,2,Y)) S:%]"" AMERDR(1)=AMERDR(1)_";"_N_"////"_+% Q
.I X="QD24"!(X="QD25")!(X="QD9") S AMERDR(12)=$G(AMERDR(12)),Y=$E(X,3,4),%=$G(^TMP("AMER",$J,2,Y)) S:((AMERDR(12)]"")&%) AMERDR(12)=AMERDR(12)_";" S:% AMERDR(12)=AMERDR(12)_N_"////"_% Q
.S I=$P(Z,U,3) I 'I Q
.S %=$G(^TMP("AMER",$J,J,I)) I %?1.N1"^"1.E S %=+%
.I A]"",%]"" S A=A_";"
.I %]"" S A=A_N_"////"_%
.Q
Q A
;
DRM ; GIVEN THE 2ND DR STRING, ADD MULTIPLES
N X,Y,A,%,C,B,Z,I,M
F X=10,26,11 D
.I $O(^TMP("AMER",$J,2,X,0)) D
..S Y=0,A=""
..F S Y=$O(^TMP("AMER",$J,2,X,Y)) Q:'Y D
...S:A]"" A=A_U
...S A=A_$G(^TMP("AMER",$J,2,X,Y))
...I A]"" S AMERDR($S(X=10:4,X=26:5,X=11:6))=A
..Q
.Q
;
;AMER*3.0*7;No longer save additional DX information
;I $O(^TMP("AMER",$J,2,11,0)) S (Y,I)=0,Z="" F S Y=$O(^TMP("AMER",$J,2,11,Y)) Q:'Y S A=^(Y) D
;.S B=+A,%=$P(A,U,2),C=$P(%," [")
;.I Z]"" S Z=Z_U
;.S Z=Z_B,I=I+1
;.S AMERDR(6)=Z,AMERDR(6,I)=C
;.Q
; ADDED FOR ER CONSULTANT MULTIPLE FIELD
I $O(^TMP("AMER",$J,2,7,0)) D
.S (Y,I)=0,Z="" F S Y=$O(^TMP("AMER",$J,2,7,Y)) Q:'Y S A=^(Y) D
..S B=+A,%=$P(A,U,2),C=$P(%,U,1),T=$P(A,U,3),N=$P(A,U,4)
..I Z]"" S Z=Z_U
..S Z=Z_B,I=I+1
..S AMERDR(3)=Z,AMERDR(3,I,.01)=C,AMERDR(3,I,.02)=T,AMERDR(3,I,.03)=N
..Q
.Q
Q
;
KILLADM ; ENTRY POINT FROM AMER2
K DIC,DIE,DA,DR
S DIK="^AMERADM(",DA=AMERDFN D ^DIK
K DIK,DA,DR,DIC,%,%H,X,Y
K AMERDEST,AMERDFN,AMERFIN,AMERQNO,AMERQSEQ,AMERRUN,AMERSTRT,AUPNDAYS,AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX
K ^TMP("AMER",$J)
Q
;
TASK ; SETS TASKMAN VARIABLES AND CALLS TASKMAN
NOTSK D UPDATE S ZTSK=1
TSK ;
I $D(AMERSTUF) Q
W !!,AMERLINE
I $D(ZTSK)!($G(AMERDEMO)) W !!,"Data entry session successfully completed...Thank you" K ZTSK H 2 Q
W !!,*7,"Data entry session terminated due to internal error.",!,"ER VISIT file not updated...Sorry!!!!"
K ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
Q
;
UPDATE ; EP - UPDATE THE VISIT FILE
N AMERAIEN,AMEREDNO,AMERDUZ,AMERPCC,AMERTIME,AMERDFN,AMERDISP,AMERREGX,AMERSTOP
S AMERSTOP=0 ;IHS/OIT/SCR 10/14/08 - STOP THE PCC UPDATE IF DISPOSITION IS REGISTERED IN ERROR
S AMERDA=$$RUN^AMERSAV1
; AMERDA contains the newly created ER VISIT SAVED FROM INFO IN AMERADM
; User has completed making initial changes to this visit and it is now in ER VISIT file
; NOW make sure all applical fields match this information in VISIT files
S AMERPCC=$$FINDVSIT^AMERPCC(AMERDA)
;IHS/OIT/SCR 10/14/08 - START if the disposition that was just saved is REGISTERED IN ERROR
; no visit should be created and an existing visit needs to be removed
S AMERDISP=$P($G(^AMERVSIT(AMERDA,6)),U,1)
N DIC,X,Y
S DIC(0)="",DIC="^AMER(3,",X="REGISTERED IN ERROR"
D ^DIC
S AMERREGX=+Y
;S AMERREGX=144
S AMERSTOP=(AMERDISP=AMERREGX)
I ((AMERPCC>0)&($G(AMERSTOP)=1)) S AMERPCC=0 ;IHS/OIT/SCR 10/14/08
I ((AMERPCC<0)&'$G(AMERSTOP)) D ; IF WE HAVEN'T MADE A VISIT YET (AS IN BATCH ENTRY) MAKE IT NOW
.S AMERTIME=$P($G(^AMERVSIT(AMERDA,0)),U,1)
.S AMERDFN=$P($G(^AMERVSIT(AMERDA,0)),U,2)
.; If the LOCATION is not set up for scheduling create a PCC VISIT through ERS PCC interface $$VISIT^AMPERPCC(AMERDFN,AMERTIME)
.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)
.D:+AMERPCC>0 SAVPCCO^AMERPCC(+AMERPCC,AMERDA) ; SAVE PCC IEN TO ER VISIT FILE
.Q
D:(+AMERPCC>0&'$G(AMERSTOP)) SYNCHPCC^AMERPCC(AMERDA)
;
;AMER*3.0*8;Update V EMERGENCY VISIT MANAGEMENT
I +AMERPCC>0,'$G(AMERSTOP) D VER^AMERVER(DFN,AMERPCC)
;
D:+AMERPCC<0
.D EN^DDIOL("There was a problem updating PCC VISIT files for ER VISIT IEN: "_AMERDA,"","!!")
.H 2
.Q
D:AMERSTOP
.D DELETVST^AMERVSIT(AMERDA) ;THIS DELETES BOTH THE PCC VISIT AND THE ERS VISIT
.D EN^DDIOL("This REGISTERED IN ERROR VISIT has been deleted")
.H 2
.Q
Q
;
STUFF(P) ; STUFF COMPUTED VALUES INTO DR STRING
I '$G(P) Q
N X,Y,Z,%,A,B,V
S X="AA" F S X=$O(^AMER(2.3,"B",X)) Q:X]"AA3" S Y=$O(^(X,0)) Q:'Y S Z=^AMER(2.3,Y,0) D
.S A=$P(Z,U,4),B=$P(Z,U,5)
.S %=$P($G(^DD(9009081,A,0)),U,4) I %="" Q
.S V=$P($G(^AMERADM(P,$P(%,";"))),U,$P(%,";",2))
.I V="" Q
.I V?1.N1"^"1.E S V=+V
.S AMERDR(1)=AMERDR(1)_";"_B_"////"_V
.Q
Q
;
CONSULT ; ER CONSULTANT WAS NOTIFIED indicated by an entry in ^TMP("AMER",$J,2,7,1)
I '$O(^TMP("AMER",$J,2,7,0)) S AMERDR(2)=AMERDR(2)_";.22////0"
E S AMERDR(2)=AMERDR(2)_";.22////1"
Q
200() ;ENTRY POINT FROM AMERSAV2
; -- SUBRTN to determine if PCC converted to file 200 yet
Q $S($P(^DD(9000010.06,.01,0),U,2)[200:1,1:0)
XXX ;
AMERSAV ; IHS/ANMC/GIS -ISC - FILE INFO IN ER VISIT FILE ;
+1 ;;3.0;ER VISIT SYSTEM;**6,7,8**;MAR 03, 2009;Build 23
+2 ;
+3 ;IHS/OIT/SCR 12/17/08
+4 ;This routine is called by AMERD upon discharge of ER
+5 ;TMP globals that are initially populated by info in ER ADMIT and now contain OUT info
+6 ;are being transfered to the ^AMERVSIT file
RUN ;
+1 ; Transfer PCC VISIT ien
+2 SET AMERDR(1)=$$DR1("QA")
+3 SET AMERDR(1)=AMERDR(1)_";.03////"_$PIECE($GET(^AMERADM(AMERDFN,0)),U,3)
+4 SET AMERDR(2)=$$DR1("QD")_";.19////"_$GET(DUZ)_";10.1////1"
+5 ;AMER*3.0*7;Stop updating DX information at this point - now getting pushed from PCC
+6 ;S %=$G(^TMP("AMER",$J,2,11,.1)) I %]"" S AMERDR(2)=AMERDR(2)_";5.2////"_+%_";5.3////"_$P($P(%,U,2)," [") ; PRIMARY DIAGNOSIS
+7 ;I %]"" S AMERDR(2)=AMERDR(2)_";5.2////"_+%_";5.3////"_$P($P(%,U,2)," [") ; PRIMARY DIAGNOSIS
SET %=$GET(^TMP("AMER",$JOB,2,11,.1))
+8 DO INJ^AMERSAV1
+9 DO CONSULT
+10 DO STUFF(AMERDFN)
DO DRM
DO KILLADM
DO TASK
EXIT QUIT
+1 ;
DR1(T) ; MAKES DR STRING FROM TMP GLOBALS. DOES NOT DO SUBFILES
+1 NEW X,Y,Z,%,I,J,N,A,AMERSTOP
SET A=""
SET J=1+(T="QD")
+2 SET X=T
FOR
SET X=$ORDER(^AMER(2.3,"B",X))
IF $EXTRACT(X,1,2)'=T
QUIT
SET Y=$ORDER(^(X,0))
IF 'Y
QUIT
Begin DoDot:1
+3 IF X="QD5"
DO XXX
+4 IF T="QD"
IF +$PIECE(X,"QD",2)>30
QUIT
+5 IF X="QA2"
SET AMERDR(.01)=$GET(^TMP("AMER",$JOB,1,2))
QUIT
+6 SET Z=^AMER(2.3,Y,0)
+7 IF $PIECE(Z,U,7)
QUIT
+8 SET N=$PIECE(Z,U,5)
IF 'N
QUIT
+9 IF X="QA3"
SET %=$GET(^TMP("AMER",$JOB,1,3))
IF %]""
SET AMERDR(1.1)=N_"////"_%
QUIT
+10 ;
+11 ;AMER*3.0*6;No longer convert
+12 ;I X="QD33" D Q
+13 ;.S %=$G(^TMP("AMER",$J,2,33)) S:% %=$G(^AMER(3,+%,"ICD")) S:% A=A_";"_N_"////"_% Q
+14 IF X="QD33"
SET %=$GET(^TMP("AMER",$JOB,2,33))
IF %
SET A=A_";"_N_"////"_%
QUIT
+15 ;
+16 IF X="QD16"
SET %=$GET(^TMP("AMER",$JOB,2,16))
IF %]""
SET AMERDR(2.1)=N_"////"_+%
QUIT
+17 IF X]"QD19"
IF X']"QD23"
SET Y=$EXTRACT(X,3,4)
SET %=$GET(^TMP("AMER",$JOB,2,Y))
IF %]""
SET AMERDR(1)=AMERDR(1)_";"_N_"////"_+%
QUIT
+18 IF X="QD24"!(X="QD25")!(X="QD9")
SET AMERDR(12)=$GET(AMERDR(12))
SET Y=$EXTRACT(X,3,4)
SET %=$GET(^TMP("AMER",$JOB,2,Y))
IF ((AMERDR(12)]"")&%)
SET AMERDR(12)=AMERDR(12)_";"
IF %
SET AMERDR(12)=AMERDR(12)_N_"////"_%
QUIT
+19 SET I=$PIECE(Z,U,3)
IF 'I
QUIT
+20 SET %=$GET(^TMP("AMER",$JOB,J,I))
IF %?1.N1"^"1.E
SET %=+%
+21 IF A]""
IF %]""
SET A=A_";"
+22 IF %]""
SET A=A_N_"////"_%
+23 QUIT
End DoDot:1
+24 QUIT A
+25 ;
DRM ; GIVEN THE 2ND DR STRING, ADD MULTIPLES
+1 NEW X,Y,A,%,C,B,Z,I,M
+2 FOR X=10,26,11
Begin DoDot:1
+3 IF $ORDER(^TMP("AMER",$JOB,2,X,0))
Begin DoDot:2
+4 SET Y=0
SET A=""
+5 FOR
SET Y=$ORDER(^TMP("AMER",$JOB,2,X,Y))
IF 'Y
QUIT
Begin DoDot:3
+6 IF A]""
SET A=A_U
+7 SET A=A_$GET(^TMP("AMER",$JOB,2,X,Y))
+8 IF A]""
SET AMERDR($SELECT(X=10:4,X=26:5,X=11:6))=A
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 ;
+12 ;AMER*3.0*7;No longer save additional DX information
+13 ;I $O(^TMP("AMER",$J,2,11,0)) S (Y,I)=0,Z="" F S Y=$O(^TMP("AMER",$J,2,11,Y)) Q:'Y S A=^(Y) D
+14 ;.S B=+A,%=$P(A,U,2),C=$P(%," [")
+15 ;.I Z]"" S Z=Z_U
+16 ;.S Z=Z_B,I=I+1
+17 ;.S AMERDR(6)=Z,AMERDR(6,I)=C
+18 ;.Q
+19 ; ADDED FOR ER CONSULTANT MULTIPLE FIELD
+20 IF $ORDER(^TMP("AMER",$JOB,2,7,0))
Begin DoDot:1
+21 SET (Y,I)=0
SET Z=""
FOR
SET Y=$ORDER(^TMP("AMER",$JOB,2,7,Y))
IF 'Y
QUIT
SET A=^(Y)
Begin DoDot:2
+22 SET B=+A
SET %=$PIECE(A,U,2)
SET C=$PIECE(%,U,1)
SET T=$PIECE(A,U,3)
SET N=$PIECE(A,U,4)
+23 IF Z]""
SET Z=Z_U
+24 SET Z=Z_B
SET I=I+1
+25 SET AMERDR(3)=Z
SET AMERDR(3,I,.01)=C
SET AMERDR(3,I,.02)=T
SET AMERDR(3,I,.03)=N
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
KILLADM ; ENTRY POINT FROM AMER2
+1 KILL DIC,DIE,DA,DR
+2 SET DIK="^AMERADM("
SET DA=AMERDFN
DO ^DIK
+3 KILL DIK,DA,DR,DIC,%,%H,X,Y
+4 KILL AMERDEST,AMERDFN,AMERFIN,AMERQNO,AMERQSEQ,AMERRUN,AMERSTRT,AUPNDAYS,AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX
+5 KILL ^TMP("AMER",$JOB)
+6 QUIT
+7 ;
TASK ; SETS TASKMAN VARIABLES AND CALLS TASKMAN
NOTSK DO UPDATE
SET ZTSK=1
TSK ;
+1 IF $DATA(AMERSTUF)
QUIT
+2 WRITE !!,AMERLINE
+3 IF $DATA(ZTSK)!($GET(AMERDEMO))
WRITE !!,"Data entry session successfully completed...Thank you"
KILL ZTSK
HANG 2
QUIT
+4 WRITE !!,*7,"Data entry session terminated due to internal error.",!,"ER VISIT file not updated...Sorry!!!!"
+5 KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
+6 QUIT
+7 ;
UPDATE ; EP - UPDATE THE VISIT FILE
+1 NEW AMERAIEN,AMEREDNO,AMERDUZ,AMERPCC,AMERTIME,AMERDFN,AMERDISP,AMERREGX,AMERSTOP
+2 ;IHS/OIT/SCR 10/14/08 - STOP THE PCC UPDATE IF DISPOSITION IS REGISTERED IN ERROR
SET AMERSTOP=0
+3 SET AMERDA=$$RUN^AMERSAV1
+4 ; AMERDA contains the newly created ER VISIT SAVED FROM INFO IN AMERADM
+5 ; User has completed making initial changes to this visit and it is now in ER VISIT file
+6 ; NOW make sure all applical fields match this information in VISIT files
+7 SET AMERPCC=$$FINDVSIT^AMERPCC(AMERDA)
+8 ;IHS/OIT/SCR 10/14/08 - START if the disposition that was just saved is REGISTERED IN ERROR
+9 ; no visit should be created and an existing visit needs to be removed
+10 SET AMERDISP=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,1)
+11 NEW DIC,X,Y
+12 SET DIC(0)=""
SET DIC="^AMER(3,"
SET X="REGISTERED IN ERROR"
+13 DO ^DIC
+14 SET AMERREGX=+Y
+15 ;S AMERREGX=144
+16 SET AMERSTOP=(AMERDISP=AMERREGX)
+17 ;IHS/OIT/SCR 10/14/08
IF ((AMERPCC>0)&($GET(AMERSTOP)=1))
SET AMERPCC=0
+18 ; IF WE HAVEN'T MADE A VISIT YET (AS IN BATCH ENTRY) MAKE IT NOW
IF ((AMERPCC<0)&'$GET(AMERSTOP))
Begin DoDot:1
+19 SET AMERTIME=$PIECE($GET(^AMERVSIT(AMERDA,0)),U,1)
+20 SET AMERDFN=$PIECE($GET(^AMERVSIT(AMERDA,0)),U,2)
+21 ; If the LOCATION is not set up for scheduling create a PCC VISIT through ERS PCC interface $$VISIT^AMPERPCC(AMERDFN,AMERTIME)
+22 IF $GET(^AMER(2.5,DUZ(2),"SD"))=""
SET AMERPCC=$$VISIT^AMERPCC(AMERDFN,AMERTIME)
+23 ; If the LOCATION is set up for scheduling create a PCC VISIT through ERS interface CHECKIN^AMERBSDU(AMERDFN,AMERTIME)
+24 IF $GET(^AMER(2.5,DUZ(2),"SD"))'=""
SET AMERPCC=$$ERCHCKIN^AMERBSDU(AMERDFN,AMERTIME)
+25 ; SAVE PCC IEN TO ER VISIT FILE
IF +AMERPCC>0
DO SAVPCCO^AMERPCC(+AMERPCC,AMERDA)
+26 QUIT
End DoDot:1
+27 IF (+AMERPCC>0&'$GET(AMERSTOP))
DO SYNCHPCC^AMERPCC(AMERDA)
+28 ;
+29 ;AMER*3.0*8;Update V EMERGENCY VISIT MANAGEMENT
+30 IF +AMERPCC>0
IF '$GET(AMERSTOP)
DO VER^AMERVER(DFN,AMERPCC)
+31 ;
+32 IF +AMERPCC<0
Begin DoDot:1
+33 DO EN^DDIOL("There was a problem updating PCC VISIT files for ER VISIT IEN: "_AMERDA,"","!!")
+34 HANG 2
+35 QUIT
End DoDot:1
+36 IF AMERSTOP
Begin DoDot:1
+37 ;THIS DELETES BOTH THE PCC VISIT AND THE ERS VISIT
DO DELETVST^AMERVSIT(AMERDA)
+38 DO EN^DDIOL("This REGISTERED IN ERROR VISIT has been deleted")
+39 HANG 2
+40 QUIT
End DoDot:1
+41 QUIT
+42 ;
STUFF(P) ; STUFF COMPUTED VALUES INTO DR STRING
+1 IF '$GET(P)
QUIT
+2 NEW X,Y,Z,%,A,B,V
+3 SET X="AA"
FOR
SET X=$ORDER(^AMER(2.3,"B",X))
IF X]"AA3"
QUIT
SET Y=$ORDER(^(X,0))
IF 'Y
QUIT
SET Z=^AMER(2.3,Y,0)
Begin DoDot:1
+4 SET A=$PIECE(Z,U,4)
SET B=$PIECE(Z,U,5)
+5 SET %=$PIECE($GET(^DD(9009081,A,0)),U,4)
IF %=""
QUIT
+6 SET V=$PIECE($GET(^AMERADM(P,$PIECE(%,";"))),U,$PIECE(%,";",2))
+7 IF V=""
QUIT
+8 IF V?1.N1"^"1.E
SET V=+V
+9 SET AMERDR(1)=AMERDR(1)_";"_B_"////"_V
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
CONSULT ; ER CONSULTANT WAS NOTIFIED indicated by an entry in ^TMP("AMER",$J,2,7,1)
+1 IF '$ORDER(^TMP("AMER",$JOB,2,7,0))
SET AMERDR(2)=AMERDR(2)_";.22////0"
+2 IF '$TEST
SET AMERDR(2)=AMERDR(2)_";.22////1"
+3 QUIT
200() ;ENTRY POINT FROM AMERSAV2
+1 ; -- SUBRTN to determine if PCC converted to file 200 yet
+2 QUIT $SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:1,1:0)
XXX ;
