Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMER4

AMER4.m

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