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

AMER0.m

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