AMER4 ; IHS/ANMC/GIS - ER VISIT SUMMARY ;
;;3.0;ER VISIT SYSTEM;**6,7**;MAR 03, 2009;Build 5
;
EDIT ; NEED TO REEDIT??
I $D(IOF) W @IOF
K AMEREFLG
S %=$P(^DPT(AMERDFN,0),U),%=$P(%,",",2,99)_" "_$P(%,",")
W "Summary of this ER data entry session for ",%," =>"
W ! D FORMAT,PRINT S AMERDEST="PRINT"
YN W !!,"*Do you want to make any changes" S %=2
D YN^DICN S:%Y?1."^^" DIROUT="" D OUT^AMER I $D(AMERQUIT) Q
I $E(%Y)=U W !,*7,"Sorry...You may not 'back up' here. Enter '^^' if you want to exit.",!! K % G YN
I %Y="" S %Y=$S(%=1:"Y",1:"N")
S (X,Y)='("Nn"[$E(%Y))
I 'Y Q
I $D(AMERTRG) S Y=1,AMEREFLG="" D ADM Q
S DIR(0)="SO^1:ADMISSION SUMMARY;2:CAUSE OF VISIT;3:INJURY INFO;4:PROCEDURES;5:EXIT ASSESSMENT;6:DISPOSITION;7:DISCHARGE INFO;8:FOLLOW UP INSTRUCTIONS"
S DIR(0)=DIR(0)_";9:ER CONSULTANTS"
S DIR("A")="Which section do you want to edit",DIR("?")="Select one choice." D ^DIR K DIR
I Y="" Q
D OUT^AMER I $D(AMERQUIT) Q
S AMEREFLG=""
ED I Y=1 D ADM Q
S %=$P("^5;5^2;71^10;10^11;12^14;15^17;19^16;16^6;8",U,Y)
S AMERSTRT=+%,AMERFIN=$P(%,";",2)
D EDIT^AMERD
Q
;
PRINT ; PRINT VISIT SUMMARY
N X,Y,Z,I,T,C,L,% S L=2
S C="ADMISSION SUMMARY^CAUSE OF VISIT^INJURY INFORMATION^ER PROCEDURES^ER CONSULTANT^EXIT ASSESSMENT^DISPOSITION^DISCHARGE INFO^FOLLOW UP INSTRUCTIONS"
I $D(AMERTRG) S C="ADMISSION SUMMARY"
;IHS/OIT/SCR 10/09/08 Removed display of fields that are no longer populated
;I $G(^TMP("AMER",$J,2,33))=+$O(^AMER(3,"B","MOTOR VEHICLE",0)) S C=C_U_"MOTOR VEHICLE COLLISION INFO"
F I=1:1 S X=$P(C,U,I) Q:X="" D
. S Y=$O(^AMER(2,"B",X,0)) I 'Y Q
. I '$D(^TMP("AMER",$J,3,Y)) Q
. W ?20,"--- ",X," ---" S T=0
. F N=0:0 S N=$O(^TMP("AMER",$J,3,Y,N)) Q:'N S Z=^TMP("AMER",$J,3,Y,N) D
..I (N=6)&(Y=38) Q ;SCR - don't want to print "ER CONSULTANTS: YES"
..I Z["^" D ;Multiple fields are returned with this separator
...F I1=1:1 S Z=$P(^TMP("AMER",$J,3,Y,N),U,I1) Q:Z="" W !,Z
..E D
...I 'T D INC W Z S:$L(Z)<39 T=1 Q
... I $L(Z)<39 W ?40,Z S T=0 Q
...D INC W Z S T=0
...Q
..Q
.D INC
.Q
Q
INC ; LINE COUNTER
N X,Y
S L=L+1 W !
I '(L#($G(IOSL,24)-0)) S DIR(0)="E",DIR("A")="Press 'Return to continue" D ^DIR W *13,?$G(IOM,80)-1,*13 K DIR,DUOUT,DTOUT,DIROUT
Q
;
OT(V,T) ;ENTRY POINT FROM AMER5
; OUTPUT TRANSFORM
; 1 = DATE
; 2 = ER OPTIONS FILE
; 3 = ER LOCAL FACILITY FILE
; 4 = Patient
; 5 = Person (doctor name)
; 6 = Yes/No
; 7 = ICD9/ICD10
; 8 = ER CONSULTANT
N Y
S Y=""
I V?1.N1"^"1.E S Y=$P(V,U,2) Q Y
I T=1 S Y=V X ^DD("DD") Q Y
I T=2 S Y=$P($G(^AMER(3,+V,0)),U) Q Y
I T=3 S Y=$P($G(^AMER(2.1,+V,0)),U) Q Y
I T=4 S Y=$P($G(^DPT(+V,0)),U) Q Y
I T=5 S Y=$P($G(^VA(200,+V,0)),U) Q Y
I T=6 S Y=$S(V=1:"YES",1:"NO") Q Y
I T=7 D
. ;AMER*3.0*6;Change ICD lookup
. NEW VDT
. S VDT=$$GET1^DIQ(9009081,DFN_",",1,"I") S:VDT="" VDT=DT
. S Y=$$DX^AMERPOV(+V,"",1,VDT)
;
I T=8 S Y=$P($G(^AMER(2.9,+V,0)),U) Q Y
Q Y
;
;
MULT(N) ; FORMATS MULTIPLES
; N = 10 - Procedure - contains a pointer to ER OPTIONS file
; - want to return a list of numbers and names
; N = 11 - Diagnosis - contains a pointer to ICD Diagnostic file
; - want to return a list of numbers and names
; N = 7 - ER Consultants - want to return a list of
; - Consultant Types, times, and Person
;
;N A,X,I S A="" ;AMER*2.5*1 req 5 IHS/OIT/SCR 2/15/06 replaced with following two lines
;
;AMER*3.0*7;Special code to get DX information
I N=11 Q $$DX($G(AMERDFN))
;
N A,X,I,K1,K2,K3
S A=""
I $D(^TMP("AMER",$J,2,N))<10 Q ""
F I=0:0 S I=$O(^TMP("AMER",$J,2,N,I)) Q:'I D
.I $D(^TMP("AMER",$J,2,N,I))<10 D
.. S X=^TMP("AMER",$J,2,N,I)
.. S X=$$OT(X,2) I X="" Q
.. I A]"" S A=A_"^ "
.. S A=A_X
..Q
.E D
..S K1=$G(^TMP("AMER",$J,2,N,I,.01)) Q:'K1
..S K2=$G(^TMP("AMER",$J,2,N,I,.02))
..S K3=$G(^TMP("AMER",$J,2,N,I,.03))
..S K1=$$OT(K1,8)
..S K2=$$OT(K2,1)
..S K3=$$OT(K3,5)
.. I A]"" S A=A_"^ "
.. S A=A_K1_" @ "_K2_" "_K3
.. Q
Q A
;
FORMAT ; SETS UTL ARRAY FOR VISIT SUMMARY
N X,Y,Z,I,N,V,H,C,%,Q
S X="QA" F S X=$O(^AMER(2.3,"B",X)) Q:$E(X)'="Q" D
. S Y=$O(^AMER(2.3,"B",X,"")) I 'Y Q
. S Z=^AMER(2.3,Y,0),Q=$P(Z,U),N=$P(Z,U,3) I 'N Q
. S C=$P(Z,U,8) I 'C Q
. S T=$P(Z,U,9),H=$G(^AMER(2.3,Y,2)) I H="" Q
. I $P(Z,U,7)]"" S ^TMP("AMER",$J,3,C,N)=H_": "_$$MULT(N) Q
. S V=$G(^TMP("AMER",$J,1+($E(Q,2)="D"),N))
. I V]"",T S V=$$OT(V,T)
. S ^TMP("AMER",$J,3,C,N)=H_": "_V
. Q
Q
;
ADM ; ADMISSION SEQUENCE
N AMERTFLG,AMERXSEQ
S AMERSTRT=2
ADM1 S AMERFIN=14 D EDIT^AMER
I AMERQSEQ'[2 Q
S AMERXSEQ=AMERQSEQ
S AMERSTRT=20,AMERFIN=25 K AMERTFLG D EDIT^AMERD
I '$D(AMERTFLG) Q
S AMERQSEQ=AMERXSEQ
S AMERSTRT=+$P(AMERQSEQ,";",$L(AMERQSEQ,";")-1)
S AMERQSEQ=$P(AMERQSEQ,";",1,$L(AMERQSEQ,";")-2)_";"
G ADM1
Q
;
DX(AMERDFN) ;Set up DX information for display
;
I $G(AMERDFN)="" Q ""
;
NEW AMERPCC,AMERPOV,PVCNT,VDT,VAL
;
S VAL=""
;
;Get the visit
S AMERPCC=$$GET1^DIQ(9009081,AMERDFN_",","1.1","I") Q:AMERPCC="" VAL
S VDT=$P($$GET1^DIQ(9000010,AMERPCC,.01,"I"),".")
;
;Process each one
S AMERPOV="" F PVCNT=1:1 S AMERPOV=$O(^AUPNVPOV("AD",AMERPCC,AMERPOV)) Q:AMERPOV="" D
. NEW ICDIEN,INFO,PS
. ;
. ;Pull each entry
. S ICDIEN=$$GET1^DIQ(9000010.07,AMERPOV,.01,"I")
. S PS=$$GET1^DIQ(9000010.07,AMERPOV,.12,"I")
. S INFO=$$ICDDX^AUPNVUTL(ICDIEN,VDT)
. S VAL=VAL_$S(VAL]"":"^ ",1:"")_"["_PS_"] "_$$VAL^XBDIQ1(9000010.07,AMERPOV,.04)_" ["_$P(INFO,U,2)_"]"
;
Q VAL
AMER4 ; IHS/ANMC/GIS - ER VISIT SUMMARY ;
+1 ;;3.0;ER VISIT SYSTEM;**6,7**;MAR 03, 2009;Build 5
+2 ;
EDIT ; NEED TO REEDIT??
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL AMEREFLG
+3 SET %=$PIECE(^DPT(AMERDFN,0),U)
SET %=$PIECE(%,",",2,99)_" "_$PIECE(%,",")
+4 WRITE "Summary of this ER data entry session for ",%," =>"
+5 WRITE !
DO FORMAT
DO PRINT
SET AMERDEST="PRINT"
YN WRITE !!,"*Do you want to make any changes"
SET %=2
+1 DO YN^DICN
IF %Y?1."^^"
SET DIROUT=""
DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+2 IF $EXTRACT(%Y)=U
WRITE !,*7,"Sorry...You may not 'back up' here. Enter '^^' if you want to exit.",!!
KILL %
GOTO YN
+3 IF %Y=""
SET %Y=$SELECT(%=1:"Y",1:"N")
+4 SET (X,Y)='("Nn"[$EXTRACT(%Y))
+5 IF 'Y
QUIT
+6 IF $DATA(AMERTRG)
SET Y=1
SET AMEREFLG=""
DO ADM
QUIT
+7 SET DIR(0)="SO^1:ADMISSION SUMMARY;2:CAUSE OF VISIT;3:INJURY INFO;4:PROCEDURES;5:EXIT ASSESSMENT;6:DISPOSITION;7:DISCHARGE INFO;8:FOLLOW UP INSTRUCTIONS"
+8 SET DIR(0)=DIR(0)_";9:ER CONSULTANTS"
+9 SET DIR("A")="Which section do you want to edit"
SET DIR("?")="Select one choice."
DO ^DIR
KILL DIR
+10 IF Y=""
QUIT
+11 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+12 SET AMEREFLG=""
ED IF Y=1
DO ADM
QUIT
+1 SET %=$PIECE("^5;5^2;71^10;10^11;12^14;15^17;19^16;16^6;8",U,Y)
+2 SET AMERSTRT=+%
SET AMERFIN=$PIECE(%,";",2)
+3 DO EDIT^AMERD
+4 QUIT
+5 ;
PRINT ; PRINT VISIT SUMMARY
+1 NEW X,Y,Z,I,T,C,L,%
SET L=2
+2 SET C="ADMISSION SUMMARY^CAUSE OF VISIT^INJURY INFORMATION^ER PROCEDURES^ER CONSULTANT^EXIT ASSESSMENT^DISPOSITION^DISCHARGE INFO^FOLLOW UP INSTRUCTIONS"
+3 IF $DATA(AMERTRG)
SET C="ADMISSION SUMMARY"
+4 ;IHS/OIT/SCR 10/09/08 Removed display of fields that are no longer populated
+5 ;I $G(^TMP("AMER",$J,2,33))=+$O(^AMER(3,"B","MOTOR VEHICLE",0)) S C=C_U_"MOTOR VEHICLE COLLISION INFO"
+6 FOR I=1:1
SET X=$PIECE(C,U,I)
IF X=""
QUIT
Begin DoDot:1
+7 SET Y=$ORDER(^AMER(2,"B",X,0))
IF 'Y
QUIT
+8 IF '$DATA(^TMP("AMER",$JOB,3,Y))
QUIT
+9 WRITE ?20,"--- ",X," ---"
SET T=0
+10 FOR N=0:0
SET N=$ORDER(^TMP("AMER",$JOB,3,Y,N))
IF 'N
QUIT
SET Z=^TMP("AMER",$JOB,3,Y,N)
Begin DoDot:2
+11 ;SCR - don't want to print "ER CONSULTANTS: YES"
IF (N=6)&(Y=38)
QUIT
+12 ;Multiple fields are returned with this separator
IF Z["^"
Begin DoDot:3
+13 FOR I1=1:1
SET Z=$PIECE(^TMP("AMER",$JOB,3,Y,N),U,I1)
IF Z=""
QUIT
WRITE !,Z
End DoDot:3
+14 IF '$TEST
Begin DoDot:3
+15 IF 'T
DO INC
WRITE Z
IF $LENGTH(Z)<39
SET T=1
QUIT
+16 IF $LENGTH(Z)<39
WRITE ?40,Z
SET T=0
QUIT
+17 DO INC
WRITE Z
SET T=0
+18 QUIT
End DoDot:3
+19 QUIT
End DoDot:2
+20 DO INC
+21 QUIT
End DoDot:1
+22 QUIT
INC ; LINE COUNTER
+1 NEW X,Y
+2 SET L=L+1
WRITE !
+3 IF '(L#($GET(IOSL,24)-0))
SET DIR(0)="E"
SET DIR("A")="Press 'Return to continue"
DO ^DIR
WRITE *13,?$GET(IOM,80)-1,*13
KILL DIR,DUOUT,DTOUT,DIROUT
+4 QUIT
+5 ;
OT(V,T) ;ENTRY POINT FROM AMER5
+1 ; OUTPUT TRANSFORM
+2 ; 1 = DATE
+3 ; 2 = ER OPTIONS FILE
+4 ; 3 = ER LOCAL FACILITY FILE
+5 ; 4 = Patient
+6 ; 5 = Person (doctor name)
+7 ; 6 = Yes/No
+8 ; 7 = ICD9/ICD10
+9 ; 8 = ER CONSULTANT
+10 NEW Y
+11 SET Y=""
+12 IF V?1.N1"^"1.E
SET Y=$PIECE(V,U,2)
QUIT Y
+13 IF T=1
SET Y=V
XECUTE ^DD("DD")
QUIT Y
+14 IF T=2
SET Y=$PIECE($GET(^AMER(3,+V,0)),U)
QUIT Y
+15 IF T=3
SET Y=$PIECE($GET(^AMER(2.1,+V,0)),U)
QUIT Y
+16 IF T=4
SET Y=$PIECE($GET(^DPT(+V,0)),U)
QUIT Y
+17 IF T=5
SET Y=$PIECE($GET(^VA(200,+V,0)),U)
QUIT Y
+18 IF T=6
SET Y=$SELECT(V=1:"YES",1:"NO")
QUIT Y
+19 IF T=7
Begin DoDot:1
+20 ;AMER*3.0*6;Change ICD lookup
+21 NEW VDT
+22 SET VDT=$$GET1^DIQ(9009081,DFN_",",1,"I")
IF VDT=""
SET VDT=DT
+23 SET Y=$$DX^AMERPOV(+V,"",1,VDT)
End DoDot:1
+24 ;
+25 IF T=8
SET Y=$PIECE($GET(^AMER(2.9,+V,0)),U)
QUIT Y
+26 QUIT Y
+27 ;
+28 ;
MULT(N) ; FORMATS MULTIPLES
+1 ; N = 10 - Procedure - contains a pointer to ER OPTIONS file
+2 ; - want to return a list of numbers and names
+3 ; N = 11 - Diagnosis - contains a pointer to ICD Diagnostic file
+4 ; - want to return a list of numbers and names
+5 ; N = 7 - ER Consultants - want to return a list of
+6 ; - Consultant Types, times, and Person
+7 ;
+8 ;N A,X,I S A="" ;AMER*2.5*1 req 5 IHS/OIT/SCR 2/15/06 replaced with following two lines
+9 ;
+10 ;AMER*3.0*7;Special code to get DX information
+11 IF N=11
QUIT $$DX($GET(AMERDFN))
+12 ;
+13 NEW A,X,I,K1,K2,K3
+14 SET A=""
+15 IF $DATA(^TMP("AMER",$JOB,2,N))<10
QUIT ""
+16 FOR I=0:0
SET I=$ORDER(^TMP("AMER",$JOB,2,N,I))
IF 'I
QUIT
Begin DoDot:1
+17 IF $DATA(^TMP("AMER",$JOB,2,N,I))<10
Begin DoDot:2
+18 SET X=^TMP("AMER",$JOB,2,N,I)
+19 SET X=$$OT(X,2)
IF X=""
QUIT
+20 IF A]""
SET A=A_"^ "
+21 SET A=A_X
+22 QUIT
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET K1=$GET(^TMP("AMER",$JOB,2,N,I,.01))
IF 'K1
QUIT
+25 SET K2=$GET(^TMP("AMER",$JOB,2,N,I,.02))
+26 SET K3=$GET(^TMP("AMER",$JOB,2,N,I,.03))
+27 SET K1=$$OT(K1,8)
+28 SET K2=$$OT(K2,1)
+29 SET K3=$$OT(K3,5)
+30 IF A]""
SET A=A_"^ "
+31 SET A=A_K1_" @ "_K2_" "_K3
+32 QUIT
End DoDot:2
End DoDot:1
+33 QUIT A
+34 ;
FORMAT ; SETS UTL ARRAY FOR VISIT SUMMARY
+1 NEW X,Y,Z,I,N,V,H,C,%,Q
+2 SET X="QA"
FOR
SET X=$ORDER(^AMER(2.3,"B",X))
IF $EXTRACT(X)'="Q"
QUIT
Begin DoDot:1
+3 SET Y=$ORDER(^AMER(2.3,"B",X,""))
IF 'Y
QUIT
+4 SET Z=^AMER(2.3,Y,0)
SET Q=$PIECE(Z,U)
SET N=$PIECE(Z,U,3)
IF 'N
QUIT
+5 SET C=$PIECE(Z,U,8)
IF 'C
QUIT
+6 SET T=$PIECE(Z,U,9)
SET H=$GET(^AMER(2.3,Y,2))
IF H=""
QUIT
+7 IF $PIECE(Z,U,7)]""
SET ^TMP("AMER",$JOB,3,C,N)=H_": "_$$MULT(N)
QUIT
+8 SET V=$GET(^TMP("AMER",$JOB,1+($EXTRACT(Q,2)="D"),N))
+9 IF V]""
IF T
SET V=$$OT(V,T)
+10 SET ^TMP("AMER",$JOB,3,C,N)=H_": "_V
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
ADM ; ADMISSION SEQUENCE
+1 NEW AMERTFLG,AMERXSEQ
+2 SET AMERSTRT=2
ADM1 SET AMERFIN=14
DO EDIT^AMER
+1 IF AMERQSEQ'[2
QUIT
+2 SET AMERXSEQ=AMERQSEQ
+3 SET AMERSTRT=20
SET AMERFIN=25
KILL AMERTFLG
DO EDIT^AMERD
+4 IF '$DATA(AMERTFLG)
QUIT
+5 SET AMERQSEQ=AMERXSEQ
+6 SET AMERSTRT=+$PIECE(AMERQSEQ,";",$LENGTH(AMERQSEQ,";")-1)
+7 SET AMERQSEQ=$PIECE(AMERQSEQ,";",1,$LENGTH(AMERQSEQ,";")-2)_";"
+8 GOTO ADM1
+9 QUIT
+10 ;
DX(AMERDFN) ;Set up DX information for display
+1 ;
+2 IF $GET(AMERDFN)=""
QUIT ""
+3 ;
+4 NEW AMERPCC,AMERPOV,PVCNT,VDT,VAL
+5 ;
+6 SET VAL=""
+7 ;
+8 ;Get the visit
+9 SET AMERPCC=$$GET1^DIQ(9009081,AMERDFN_",","1.1","I")
IF AMERPCC=""
QUIT VAL
+10 SET VDT=$PIECE($$GET1^DIQ(9000010,AMERPCC,.01,"I"),".")
+11 ;
+12 ;Process each one
+13 SET AMERPOV=""
FOR PVCNT=1:1
SET AMERPOV=$ORDER(^AUPNVPOV("AD",AMERPCC,AMERPOV))
IF AMERPOV=""
QUIT
Begin DoDot:1
+14 NEW ICDIEN,INFO,PS
+15 ;
+16 ;Pull each entry
+17 SET ICDIEN=$$GET1^DIQ(9000010.07,AMERPOV,.01,"I")
+18 SET PS=$$GET1^DIQ(9000010.07,AMERPOV,.12,"I")
+19 SET INFO=$$ICDDX^AUPNVUTL(ICDIEN,VDT)
+20 SET VAL=VAL_$SELECT(VAL]"":"^ ",1:"")_"["_PS_"] "_$$VAL^XBDIQ1(9000010.07,AMERPOV,.04)_" ["_$PIECE(INFO,U,2)_"]"
End DoDot:1
+21 ;
+22 QUIT VAL
