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

AMERD.m

Go to the documentation of this file. 
  1. AMERD ; IHS/ANMC/GIS - PRIMARY ROUTINE FOR ER DISCHARGE ; 
  1.  ;;3.0;ER VISIT SYSTEM;**4,5,6,8**;MAR 03, 2009;Build 23
  1.  ;
  1. CHECK ;
  1.  I '$D(^AMERADM("B")) W !!!,*7,"Sorry...I have no record of any current admissions to the ER.",!,"Session cancelled!",!!! H 2 Q
  1.  D EXIT1^AMER K ^TMP("AMER",$J,1),^(2),^(3),AMERQUIT,AMER
  1.  ;
  1.  ;Set up discharge flag
  1.  NEW AMERDSC
  1.  S AMERDSC=1
  1.  ;
  1. VAR ; ENTRY POINT FOR BATCH MODE
  1.  S %="",$P(%,"~",80)="",AMERLINE=%,AMERSTRT=1,AMERFIN=27,AMERQSEQ="" K %
  1.  S IOP=0 D ^%ZIS
  1.  I $D(AMERBCH) S AMERSTRT=20,%=+^TMP("AMER",$J,1,1),AMERDFN=%,^TMP("AMER",$J,2,1)=% G RUN
  1.  W @IOF
  1. EDIT ; ENTRY POINT FROM AMER4 AND AMER
  1.  S AMERQSEQ=""
  1. RUN F AMERRUN=AMERSTRT:1 Q:$D(AMERBFLG)  Q:AMERRUN>AMERFIN  Q:$D(AMERQUIT)  D  Q:$D(AMERQUIT)
  1.  . I '$D(^AMER(2.3,"B",("QD"_AMERRUN))) Q
  1.  . ;
  1.  . S AMERQNO=AMERRUN W $$LINE^AMER("QD"_AMERRUN)
  1.  . D OPT^AMER("QD"_AMERRUN)
  1.  . D TRG
  1.  . D @("QD"_AMERRUN_"^AMER"_$S(AMERRUN<10:2,AMERRUN<20:3,AMERRUN<30:"2A",AMERRUN<50:"2B",1:"2C"))
  1.  . ;
  1.  . D SET
  1.  . ;
  1.  . ;AMER*3.0*5;Log activity
  1.  . D
  1.  .. NEW ERIEN,AFIELD,ADMFLD
  1.  .. S AFIELD=""
  1.  .. S ERIEN=$O(^AMER(2.3,"B","QD"_AMERRUN,"")) Q:ERIEN=""
  1.  .. S ADMFLD=$$GET1^DIQ(9009082.3,ERIEN,.04,"I")
  1.  .. I ADMFLD]"" S AFIELD=$P($G(^DD(9009081,ADMFLD,0)),U)
  1.  .. I AFIELD="" D
  1.  ... S ADMFLD=$$GET1^DIQ(9009082.3,ERIEN,.05,"I")
  1.  ... I ADMFLD]"" S AFIELD=$P($G(^DD(9009080,ADMFLD,0)),U)
  1.  .. Q:AFIELD=""
  1.  .. ;
  1.  .. ;Now log the activity
  1.  .. NEW AUDDFN
  1.  .. S AUDDFN=$G(DFN) S:AUDDFN="" AUDDFN=$G(AUPNPAT)
  1.  .. D LOG^AMERBUSA("P","E","AMER","AMER: Entered Patient ER visit information - "_AFIELD_" ("_AUDDFN_")",AUDDFN)
  1.  .. KILL AUDDFN
  1.  . ;
  1.  . I $D(AMEREFLG),AMERRUN=9 S AMERRUN=98
  1.  . K DIR,DIC
  1.  . Q
  1.  ;
  1.  I $D(AMERTFLG)!($D(AMEREFLG)) Q
  1.  I $D(AMERBFLG) Q
  1.  I $D(AMERQUIT) G EXIT
  1. FIX D ^AMER4 I $D(AMERQUIT) K AMEREFLG G EXIT
  1. ELOOP I $D(AMEREFLG) G FIX
  1.  I '$D(AMERBCH),$P($G(^AMER(3,+$G(^TMP("AMER",$J,2,14)),0)),U)="HOME" D PRINT I $D(AMERQUIT) G EXIT
  1.  I $D(AMERTRG) D TRGSET D  G EXIT
  1.  . ;
  1.  . ;AMER*3.0*8;Update V EMERGENCY VISIT RECORD entry
  1.  . D VER^AMERVER(DFN,"")
  1.  ;
  1.  D ^AMERSAV I $D(AMERQUIT) G EXIT
  1.  ;
  1.  ;AMER*3*5;Added auditing call
  1.  NEW AMERVIS
  1.  S AMERVIS=$$GET1^DIQ(9009080,AMERDA_",",.03,"I")
  1.  D LOG^AMERBUSA("P","E","AMERD","AMER: Patient Discharged from the ER ("_AMERVIS_")",DFN)
  1.  ;
  1.  ;AMER*3.0*8;Update V EMERGENCY VISIT RECORD entry
  1.  D VER^AMERVER(DFN,AMERVIS)
  1.  ;
  1.  ;AMER*3.0*4
  1.  ;Supply information to BEDD application if loaded
  1.  ;
  1.  ;First see if RPMS patch has been loaded
  1.  I $$VERSION^XPDUTL("BEDD") D
  1.  . ;
  1.  . ;Check if XML portion has been loaded
  1.  . N X
  1.  . S X="BEDDUTW" X ^%ZOSF("TEST") Q:'$T
  1.  . ;
  1.  . ;Call routine to pass info to BEDD
  1.  . I $G(AMERDA)]"" D DISCH^BEDDUTW(AMERDA)
  1.  . ;
  1.  . ;AMER*3*5;Added auditing call
  1.  . D LOG^AMERBUSA("P","E","AMERD","AMER: Patient Discharged from the ED Dashboard ("_AMERVIS_")",DFN)
  1.  ;
  1.  I $D(AMERBCH) Q
  1. EXIT D EXIT^AMER
  1.  Q
  1.  ;
  1. SET K AMERMAND I $D(AMERQUIT) Q
  1.  I AMERRUN=98 Q
  1.  ;IHS/OIT/SCR 10/15/08 try to catch a REGISTERED IN ERROR visit and stop processing
  1.  I ((AMERRUN=95)&$D(AMERBCH)) W !,"Session terminated..." S AMERQUIT="" Q
  1.  I ((AMERRUN=95)&'$D(AMRBCH)) D  Q
  1.  .S AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
  1.  .I AMERPCC>0 D
  1.  ..S APCDVDLT=AMERPCC
  1.  ..D EN^APCDVDLT
  1.  ..K APCDVDLT
  1.  ..W !,"PCC Visit deleted..."
  1.  ..N AMERTIME
  1.  ..S AMERTIME=$G(^TMP("AMER",$J,1,2))
  1.  ..D CANCEL^AMERBSDU(AMERDFN,AMERTIME)
  1.  ..;W !,"Scheduled Visit deleted..." - can't cancel a visit that has been checked in
  1.  ..Q
  1.  .D KILLADM^AMERSAV
  1.  .S AMERQUIT=""
  1.  .S AMERRUN=98
  1.  .S AMERFIN=0  ;IHS/OIT/SCR 10/15/0 A GLOBAL VARIABLE THAT NEEDS TO BE SET TO STOP QUESTIONS
  1.  I X?2."^" W !,*7,"Session terminated..." S AMERQUIT="" Q
  1.  I $E(X)=U S X=U
  1.  I X=U,$D(AMERBCH),AMERQNO=20 S AMERBFLG="" Q  ; BACKUP TO ADMISSION QUESTIONS IN BATCH MODE
  1.  I X=U,$G(AMERQNO)<2 W !,"Session terminated...",*7 S AMERQUIT="" Q
  1.  I Y=""!(Y=-1),'$D(AMEROPT),AMERRUN>1,X'=U D MAND^AMER Q
  1.  K AMEROPT
  1.  S AMERQSEQ=AMERQSEQ_AMERQNO_";"
  1.  I X=U D BACK^AMER Q
  1.  I Y=""!(Y=-1) Q
  1.  Q:AMERQNO=6
  1.  S ^TMP("AMER",$J,2,AMERQNO)=Y
  1.  Q
  1. TRGSET ; SET TRIAGE INFO IN ER ADM FILE
  1.  N AMERPCC
  1.  D ^AMER0
  1.  S AMERTRGS=20
  1.  S DA=AMERDFN,DIE="^AMERADM("
  1.  F  S AMERTRGS=$O(^TMP("AMER",$J,2,AMERTRGS)) Q:AMERTRGS'?1N.N  D
  1.  .S DR=AMERTRGS-3_"////"_$P(^TMP("AMER",$J,2,AMERTRGS),U)
  1.  .D ^DIE
  1.  .Q
  1.  S AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
  1.  I AMERPCC>0 D VPROVTRG^AMERPCC(AMERDFN,AMERPCC)
  1.  Q
  1. TRG ; SET TRIAGE INFO IN TMP FILE
  1.  S AMERTRGS=20
  1.  F  S AMERTRGS=$O(^TMP("AMER",$J,1,AMERTRGS)) Q:AMERTRGS'?1N.N  D
  1.  .S:$G(^TMP("AMER",$J,2,AMERTRGS))="" ^TMP("AMER",$J,2,AMERTRGS)=^TMP("AMER",$J,1,AMERTRGS)
  1.  Q
  1.  ;
  1. PRINT ; PRINT PATIENT INSTRUCTIONS
  1.  S AMERRUN=98
  1.  W !,"Do you want to print patient instructions"
  1.  S %=2 D YN^DICN I %Y?2."^" S DIROUT=""
  1.  D OUT^AMER
  1.  I $D(AMERQUIT) Q
  1.  I "Nn"[$E(%Y) Q
  1.  S DIR(0)="N^1:10:0",DIR("A")="Enter the number of copies you would like to print"
  1.  D ^DIR
  1.  S AMERNUM=Y
  1.  I $D(^TMP("AMER",$J,2,15)) S %=+^(15) I %'=121,%'=86,%'=87 G P1
  1.  W !,"I will print a set of follow up instructions for the patient and provider."
  1.  W !,"You can also print patient education materials...",!
  1.  S ^TMP("AMER",$J,2,26,31)=""
  1. P1 D ^AMER5
  1.  Q
  1.  ;
  1. REV ; ENTRY POINT FOR REVOLVING DOOR CALC
  1.  N N,Y,Z,%,X1,X2
  1.  S Z=0 F Y=0:0 S Y=$O(^AMERVSIT("AC",X,Y)) Q:'Y  Q:Y=DA  S %=+^AMERVSIT(Y,0) I %>Z S Z=%
  1.  I 'Z Q
  1.  S X2=Z,X1=DT,N=.5 D REV1 S $P(^AMERVSIT(DA,5),U,2)=N
  1.  Q
  1.  ;
  1. REV1 N X D ^%DTC
  1.  I X>0 S N=X
  1.  Q
  1.  ;
  1. KREV ; ENTRY POINT TO KILL REVOLVING DOOR
  1.  S $P(^AMERVSIT(DA,5),U,2)=""
  1.  Q
  1.  ;
  1. DNA ; ENTRY POINT FROM AMER DNA MENU
  1.  ; PT LEFT WITHOUT BEING SEEN
  1.  S AMERDNA=""
  1.  D AMERD K AMERDNA
  1.  Q
  1.  ;
  1. DEMO ; ENTRY POINT FOR DEMO MODE
  1.  S AMERDEMO=1
  1.  D AMERD
  1.  K AMERDEMO
  1.  Q
  1.  ;
  1. DXCK(AUPNPAT) ; Entry point to check for valid Dx entry for visit
  1.  ;
  1.  ;Quit if DFN not passed in (used to retrieve visit)
  1.  I $G(AUPNPAT)="" Q "1"
  1.  ;
  1.  NEW AMERDXLT,AMERDCNT
  1.  ;
  1.  ;Make call to get list of V POV entries
  1.  S AMERDCNT=+$$POV^AMERUTIL(AUPNPAT,"",.AMERDXLT)
  1.  ;
  1.  ;If no V POV entries, inform user and quit
  1.  I AMERDCNT=0 D
  1.  . D EN^DDIOL("**No Purpose of Visit (POV) information has been entered for this visit**","","!!")
  1.  . D EN^DDIOL("**Please use EHR/PCC to enter POV information then proceed with the discharge**","","!")
  1.  . H 3
  1.  ;
  1.  Q AMERDCNT