AMEREDTD ; IHS/OIT/SCR - Sub-routine for ER VISIT edit of discharge data
;;3.0;ER VISIT SYSTEM;**2,6**;MAR 03, 2009;Build 30
;
;DISCHARGE
;PROCEDURES
;EXIT ASSESSMENT
;FOLLOW UP INSTRUCTIONS
;
; VARIABLES: The following variables are passed to multiple editing routines
; AMERDA : the IEN of the ER VISIT that is selected for editing
; AMERAIEN: The IEN of the ER AUDIT that is created when user begins editing a record
; AMEREDNO: An integer representing the number of multiple fields that have been edited
; for uniqueness in multiple field number in audit file
;
; Edit Auditing VARIABLES newed and used throughout edit routines:
; AMEROLD : original value of edited field
; AMERNEW : new value of edited field
; AMERSTRG : A ";" deliminated string of edit information for a field
;
EDDISCHG(AMERDA,AMERAIEN) ; EP from AMEREDIT for discharge information
;QD17 - DISCHARGE PHYSICIAN
I '$D(^XUSEC("AMERZ9999",DUZ)) D EN^DDIOL("You are not authorized to use this option","","!!") Q 1 ;PROGRAMATICALLY LOCKING this option to holders of the coding key
N AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DR,DIC,DIR
N AMERDR ;IHS/OIT/SCR 08/28/09 patch 2
S (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,AMERDR)=""
S DIC("A")="*(PRIMARY)Provider who signed PCC form: " K DIC("B"),DIC("S")
S DIC("?")="Only active providers can be selected"
I $P($G(^AMERVSIT(AMERDA,6)),U,4)'="" D
.S (AMEROLD,AMERNO)=$P($G(^AMERVSIT(AMERDA,6)),U,3)
.S DIC("B")=$P($G(^VA(200,AMERNO,0)),U)
.Q
S DIC="^VA(200,",DIC(0)="AEQ"
;screening so that only valid PRIMARY providers are sent to PCC for Visit Creation
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
D ^DIC
K DIC
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
I Y>0 D
.S AMERNEW=+Y
.I AMERNEW'=AMEROLD D
..I AMERNEW="" S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.3////@"
..I AMERNEW>0 S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.3////"_AMERNEW
..S AMERSTRG=$$EDAUDIT^AMEREDAU("6.3",$$EDDISPL^AMEREDAU(AMEROLD,"N"),$$EDDISPL^AMEREDAU(AMERNEW,"N"),"DISCHARGE PROVIDER")
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..Q
.Q
;QD18 - DISCHARGE NURSE
S DIC("A")="Discharge nurse: ",AMERNO=""
K DIC("B")
S DIC("?")="Only active providers can be selected"
S (AMEROLD,AMERNO)=$P($G(^AMERVSIT(AMERDA,6)),U,4)
I AMEROLD'="" S DIC("B")=$P(^VA(200,AMERNO,0),U)
;screening so that only valid PCC providers identified
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
S DIC="^VA(200,",DIC(0)="AEQM"
D ^DIC K DIC
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
S AMERNEW=+Y
I AMERNEW'=AMEROLD D
.I AMERNEW>0 S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.4////"_AMERNEW
.S AMERSTRG=$$EDAUDIT^AMEREDAU("6.4",$$EDDISPL^AMEREDAU(AMEROLD,"N"),$$EDDISPL^AMEREDAU(AMERNEW,"N"),"DISCHARGE NURSE")
.I AMERSTRG="^" Q
.S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
.Q
;QD19 - TIME OF DEPARTURE
S AMEROLD=$P($G(^AMERVSIT(AMERDA,6)),U,2)
I AMEROLD'="" S Y=$P($G(^AMERVSIT(AMERDA,6)),U,2) X ^DD("DD") S DIR("B")=Y
S DIR(0)="DO^::ER",DIR("A")="*What time did the patient depart from the ER"
S DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)"
F Q:Y="^" D
.D ^DIR
.I $D(DUOUT)!$D(DTOUT) S Y="^" Q
.S AMERNEW=Y
.;TVAL returns 0 if user says "yes they are sure they want this time..."
.I $$TVAL^AMER2A($P($G(^AMERVSIT(AMERDA,0)),U,1),AMERNEW,6) Q
.I AMERNEW="" S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.2////@"
.I $$TCK^AMER2A($P($G(^AMERVSIT(AMERDA,0)),U,1),AMERNEW,1,"admission")=0 D
..I AMERNEW=AMEROLD S Y="^" Q
..S AMERSTRG=$$EDAUDIT^AMEREDAU("6.2",$$EDDISPL^AMEREDAU(AMEROLD,"D"),$$EDDISPL^AMEREDAU(AMERNEW,"D"),"DEPARTURE TIME")
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.2///"_AMERNEW
..S Y="^"
..Q
.Q
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
IF AMERDR'="" D
.D DIE^AMEREDIT(AMERDA,AMERDR)
.Q
D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
K AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DIC,DIR,AMERDR
Q 1
;
EDPROCS(AMERDA,AMEREDNO,AMERAIEN) ; EP from AMEREDIT - ER PROCEDURES
N AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG
S (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,Y)=""
S AMERNO=0
K DIC("B"),DIC("S")
I $P($G(^AMERVSIT(AMERDA,4,0)),U,3)="" D EN^DDIOL("No procedure(s) have been entered:","","!")
E D
.D EN^DDIOL("The following procedure(s) have been entered: ","","!")
.D EN^DDIOL("","","!")
.S AMERNO=0
.F S AMERNO=$O(^AMERVSIT(AMERDA,4,AMERNO)) Q:AMERNO="B" D
..S Y=$G(^AMERVSIT(AMERDA,4,AMERNO,0)),Y1=$G(^AMER(3,Y,0))
..D EN^DDIOL($P(Y1,U,1),"","!")
..Q
.Q
D EN^DDIOL("","","!")
F Q:Y="^" D
.S SKIP=0
.S DIC="^AMER(3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=20",Y="" ;only show type 20 -ER PROCEDURES
.S DIC("A")="Enter "_$S($P($G(^AMERVSIT(AMERDA,4,0)),U,3)>0:"another ",1:"a ")_"procedure: "
.D ^DIC
.I $G(Y)<=0 S Y="^" Q
.;First look to see if that procedure has already been entered
.;if it has, we give the user a chance to delete it
.S AMERNO=0
.F S AMERNO=$O(^AMERVSIT(AMERDA,4,AMERNO)) Q:'AMERNO I ^AMERVSIT(AMERDA,4,AMERNO,0)=$P(Y,U,1) D
..S SKIP=1
..S AMEROLD=$G(^AMERVSIT(AMERDA,4,AMERNO,0))
..S DIR(0)="Y",DIR("A")="Delete this procedure? ",DIR("B")="NO"
..D ^DIR
..I Y=1 D
...S AMEREDNO=AMEREDNO+1
...S AMERNEW=""
...S AMERSTRG=$$EDAUDIT^AMEREDAU("4-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMEROLD,"R"),$$EDDISPL^AMEREDAU(AMERNEW,"R"),"PROCEDURE")
...I AMERSTRG="^" Q
...S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
...S DA(1)=AMERDA,DA=AMERNO,DIK="^AMERVSIT(DA(1),4,"
...D ^DIK,EN^DIK K DIK ;Kill the record and Re-index
...Q
..S (AMERNO,Y)=""
..Q
.I 'SKIP D
..S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),4,",DIC(0)="L",DIC("P")=$P(^DD(9009080,4,0),U,2) ; PROCEDURES
..S AMEROLD="",AMERNEW=+Y
..S X="`"_+Y
..D ^DIC K DIC ;add a new entry
..S AMERNO=+Y,AMEREDNO=AMEREDNO+1
..S AMERSTRG=$$EDAUDIT^AMEREDAU("4-1"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMEROLD,"R"),$$EDDISPL^AMEREDAU(AMERNEW,"R"),"PROCEDURE")
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..Q
.Q
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
K AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG
Q 1
;
EDEXTAS(AMERDA,AMERAIEN) ;EP from AMEREDIT - ER EXIT ASSESSMENT
;QD12 - FINAL TRIAGE CATEGORY
N Y,AMEROLD,AMERNEW,AMEREDTS,AMERDR,AMERSTRG,AMEROPTN,AMERFAC,AMERM,DIR,DIC,AMEROPNO
S (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,AMERDR,Y)=""
S AMEROLD=$P($G(^AMERVSIT(AMERDA,5.1)),U,4)
I AMEROLD'="" S DIR("B")=AMEROLD
S DIR(0)="NO^1:5:0",DIR("A")="Enter final acuity assessment from provider"
S DIR("?")="Enter a number from 1 to 5 - This is a required field"
F Q:Y="^" D
.D ^DIR
.I $D(DUOUT)!$D(DTOUT) S Y="^" Q
.S AMERNEW=Y
.I AMERNEW=AMEROLD S Y="^" Q
.I AMERNEW>0 D
..S AMERSTRG=$$EDAUDIT^AMEREDAU("4.1",AMEROLD,AMERNEW,"FINAL ACUITY")
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"5.4///"_Y
..S Y="^"
..Q
.Q
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
I AMERDR'="" D
.D DIE^AMEREDIT(AMERDA,AMERDR)
.Q
D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
S (DR,AMEREDTS)=""
;QD14 - DISPOSITION and transfer
S AMEROPNO=""
I $P($G(^AMERVSIT(AMERDA,6)),U,1)'="" S (AMEROLD,AMEROPNO)=$P($G(^AMERVSIT(AMERDA,6)),U,1)
S DIC("A")="Disposition: " K DIC("B"),DIC("S")
S DIC="^AMER(3,",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("DISPOSITION")
I AMEROPNO'="" S DIC("B")=$P($G(^AMER(3,AMEROPNO,0)),U,1)
D ^DIC K DIC
I AMEROLD=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION") D
.D EN^DDIOL("This disposition can not be changed!!","","!")
.S AMERNEW=AMEROLD
E S AMERNEW=+Y
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
;IHS/OIT/SCR - 10/08/08 - START if the new value is Registered in error delete PCC VISIT
I (AMERNEW>0) D
.I AMERNEW=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION") D
..D EN^DDIOL("This DISPOSITION will cause this entire VISIT to be deleted!!","","!")
..S DIR(0)="Y",DIR("A")="Do you still wish to keep this DISPOSITION"
..S DIR("B")="YES"
..D ^DIR
..I Y=0 S AMERNEW=AMEROLD
..I Y=1 D
...D DELETVST^AMERVSIT(AMERDA)
...S AMERDA=0
...Q
..Q ;IHS/OIT/SCR - 10/08/08 - END if the new value is Registered in error delete PCC VISIT
.S AMEROPTN=$$OPT^AMER0("TRANSFER","DISPOSITION")
.I (AMERNEW'=AMEROLD) D
..S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.1///"_AMERNEW
..S AMERSTRG=$$EDAUDIT^AMEREDAU("6.1",$$EDDISPL^AMEREDAU(AMEROLD,"I"),$$EDDISPL^AMEREDAU(AMERNEW,"I"),"DISPOSITION")
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..;If the old value was "transfer to another facility, delete facility associated
..I AMEROLD=AMEROPTN D S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.6////@"
..Q
.I AMERNEW=AMEROPTN D
..;IF the new value is "transfer to another facility", collect facility information
..D EN^DDIOL("","","!")
..S AMEROLD=""
..I $P($G(^AMER(2.1,0)),U,3)="" D EN^DDIOL("No local ER Facilities found","","!") Q
..S DIC="^AMER(2.1,",DIC(0)="AEQM"
..S DIC("A")="Where is patient being transferred? "
..S AMERFAC=$P($G(^AMERVSIT(AMERDA,6)),U,6)
..I AMERFAC'="" S (DIC("B"),AMEROLD)=$P($G(^AMER(2.1,AMERFAC,0)),U,1)
..E S AMERM=$O(^AMER(2.1,0))
..D ^DIC K DIC
..I +Y>0 S AMERNEW=$P($G(^AMER(2.1,+Y,0)),U,1)
..E S AMERNEW=""
..I +Y>0&(AMERNEW'=AMEROLD) D
...S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.6////"_+Y
...S AMERSTRG=$$EDAUDIT^AMEREDAU("6.6",AMEROLD,AMERNEW,"TRANSFER TO")
...I AMERSTRG="^" Q
...S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
...Q
..Q
..E I AMEROPTN<0 D
...D EN^DDIOL("Option 'TRANSFER TO ANOTHER FACILITY' is missing ","","!")
...D EN^DDIOL("This DISPOSITION type is required for collection of transfer location ","","!")
...Q
..Q
.I AMEROLD=AMEROPTN
.Q ;IF NEW>0
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
IF AMERDR'="" D
.D DIE^AMEREDIT(AMERDA,AMERDR)
.Q
D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
K Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DR,AMERDR,AMEROPTN,AMERFAC,AMERM,DIR,DIC
Q 1
;
EDFUINST(AMERDA,AMERAIEN) ;EP - From AMEREDIT
;QD16 - DISCHARGE INSTRUCTIONS
NEW FIIEN,CNT,FI,DIR,%,AMEROLD
;
;Get the default entry
S AMEROLD=$$GET1^DIQ(9009080,AMERDA_",",7,"I") S:AMEROLD]"" DIR("B")=$$GET1^DIQ(9009083,AMEROLD_",",.01,"I")
;
S CNT=0
S DIR(0)="SO^"
S FIIEN=$O(^AMER(2,"B","FOLLOW UP INSTRUCTIONS",""))
S FI="" F S FI=$O(^AMER(3,"AC",FIIEN,FI)) Q:FI="" D
. S CNT=CNT+1
. S INSNM=$$GET1^DIQ(9009083,FI_",",".01","I") Q:INSNM=""
. S INS(CNT)=INSNM_U_FI
. S DIR(0)=DIR(0)_$S(CNT>1:";",1:"")_CNT_":"_INSNM
;
S DIR("A")="Follow up instructions"
D ^DIR
;
;Process invalid entries
;I +Y<1,X'="@" S X="^",Y="^" D OUT^AMER Q
;
;Handle proper selection
I +Y>0 S Y=$P(INS(+Y),U,2)
;
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
S AMERNEW=$S(+Y>0:+Y,1:"")
;
;Save/Audit
I AMERNEW'=AMEROLD D
. NEW AMERSTRG,DR
. S AMERSTRG=$$EDAUDIT^AMEREDAU("7",$$EDDISPL^AMEREDAU(AMEROLD,"F"),$$EDDISPL^AMEREDAU(AMERNEW,"F"),"DISCHARGE INSTRUCTIONS")
. S DR="7////"_$S(AMERNEW]"":AMERNEW,1:"@")
. D DIE^AMEREDIT(AMERDA,DR)
. I AMERSTRG="^" Q
. D DIEREC^AMEREDAU(AMERAIEN,AMERSTRG)
;
Q 1
AMEREDTD ; IHS/OIT/SCR - Sub-routine for ER VISIT edit of discharge data
+1 ;;3.0;ER VISIT SYSTEM;**2,6**;MAR 03, 2009;Build 30
+2 ;
+3 ;DISCHARGE
+4 ;PROCEDURES
+5 ;EXIT ASSESSMENT
+6 ;FOLLOW UP INSTRUCTIONS
+7 ;
+8 ; VARIABLES: The following variables are passed to multiple editing routines
+9 ; AMERDA : the IEN of the ER VISIT that is selected for editing
+10 ; AMERAIEN: The IEN of the ER AUDIT that is created when user begins editing a record
+11 ; AMEREDNO: An integer representing the number of multiple fields that have been edited
+12 ; for uniqueness in multiple field number in audit file
+13 ;
+14 ; Edit Auditing VARIABLES newed and used throughout edit routines:
+15 ; AMEROLD : original value of edited field
+16 ; AMERNEW : new value of edited field
+17 ; AMERSTRG : A ";" deliminated string of edit information for a field
+18 ;
EDDISCHG(AMERDA,AMERAIEN) ; EP from AMEREDIT for discharge information
+1 ;QD17 - DISCHARGE PHYSICIAN
+2 ;PROGRAMATICALLY LOCKING this option to holders of the coding key
IF '$DATA(^XUSEC("AMERZ9999",DUZ))
DO EN^DDIOL("You are not authorized to use this option","","!!")
QUIT 1
+3 NEW AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DR,DIC,DIR
+4 ;IHS/OIT/SCR 08/28/09 patch 2
NEW AMERDR
+5 SET (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,AMERDR)=""
+6 SET DIC("A")="*(PRIMARY)Provider who signed PCC form: "
KILL DIC("B"),DIC("S")
+7 SET DIC("?")="Only active providers can be selected"
+8 IF $PIECE($GET(^AMERVSIT(AMERDA,6)),U,4)'=""
Begin DoDot:1
+9 SET (AMEROLD,AMERNO)=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,3)
+10 SET DIC("B")=$PIECE($GET(^VA(200,AMERNO,0)),U)
+11 QUIT
End DoDot:1
+12 SET DIC="^VA(200,"
SET DIC(0)="AEQ"
+13 ;screening so that only valid PRIMARY providers are sent to PCC for Visit Creation
+14 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+15 DO ^DIC
+16 KILL DIC
+17 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+18 IF Y>0
Begin DoDot:1
+19 SET AMERNEW=+Y
+20 IF AMERNEW'=AMEROLD
Begin DoDot:2
+21 IF AMERNEW=""
SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.3////@"
+22 IF AMERNEW>0
SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.3////"_AMERNEW
+23 SET AMERSTRG=$$EDAUDIT^AMEREDAU("6.3",$$EDDISPL^AMEREDAU(AMEROLD,"N"),$$EDDISPL^AMEREDAU(AMERNEW,"N"),"DISCHARGE PROVIDER")
+24 IF AMERSTRG="^"
QUIT
+25 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 ;QD18 - DISCHARGE NURSE
+29 SET DIC("A")="Discharge nurse: "
SET AMERNO=""
+30 KILL DIC("B")
+31 SET DIC("?")="Only active providers can be selected"
+32 SET (AMEROLD,AMERNO)=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,4)
+33 IF AMEROLD'=""
SET DIC("B")=$PIECE(^VA(200,AMERNO,0),U)
+34 ;screening so that only valid PCC providers identified
+35 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+36 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+37 DO ^DIC
KILL DIC
+38 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+39 SET AMERNEW=+Y
+40 IF AMERNEW'=AMEROLD
Begin DoDot:1
+41 IF AMERNEW>0
SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.4////"_AMERNEW
+42 SET AMERSTRG=$$EDAUDIT^AMEREDAU("6.4",$$EDDISPL^AMEREDAU(AMEROLD,"N"),$$EDDISPL^AMEREDAU(AMERNEW,"N"),"DISCHARGE NURSE")
+43 IF AMERSTRG="^"
QUIT
+44 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+45 QUIT
End DoDot:1
+46 ;QD19 - TIME OF DEPARTURE
+47 SET AMEROLD=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,2)
+48 IF AMEROLD'=""
SET Y=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,2)
XECUTE ^DD("DD")
SET DIR("B")=Y
+49 SET DIR(0)="DO^::ER"
SET DIR("A")="*What time did the patient depart from the ER"
+50 SET DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)"
+51 FOR
IF Y="^"
QUIT
Begin DoDot:1
+52 DO ^DIR
+53 IF $DATA(DUOUT)!$DATA(DTOUT)
SET Y="^"
QUIT
+54 SET AMERNEW=Y
+55 ;TVAL returns 0 if user says "yes they are sure they want this time..."
+56 IF $$TVAL^AMER2A($PIECE($GET(^AMERVSIT(AMERDA,0)),U,1),AMERNEW,6)
QUIT
+57 IF AMERNEW=""
SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.2////@"
+58 IF $$TCK^AMER2A($PIECE($GET(^AMERVSIT(AMERDA,0)),U,1),AMERNEW,1,"admission")=0
Begin DoDot:2
+59 IF AMERNEW=AMEROLD
SET Y="^"
QUIT
+60 SET AMERSTRG=$$EDAUDIT^AMEREDAU("6.2",$$EDDISPL^AMEREDAU(AMEROLD,"D"),$$EDDISPL^AMEREDAU(AMERNEW,"D"),"DEPARTURE TIME")
+61 IF AMERSTRG="^"
QUIT
+62 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+63 SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.2///"_AMERNEW
+64 SET Y="^"
+65 QUIT
End DoDot:2
+66 QUIT
End DoDot:1
+67 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+68 IF AMERDR'=""
Begin DoDot:1
+69 DO DIE^AMEREDIT(AMERDA,AMERDR)
+70 QUIT
End DoDot:1
+71 IF AMEREDTS'=""
DO MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
+72 KILL AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DIC,DIR,AMERDR
+73 QUIT 1
+74 ;
EDPROCS(AMERDA,AMEREDNO,AMERAIEN) ; EP from AMEREDIT - ER PROCEDURES
+1 NEW AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG
+2 SET (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,Y)=""
+3 SET AMERNO=0
+4 KILL DIC("B"),DIC("S")
+5 IF $PIECE($GET(^AMERVSIT(AMERDA,4,0)),U,3)=""
DO EN^DDIOL("No procedure(s) have been entered:","","!")
+6 IF '$TEST
Begin DoDot:1
+7 DO EN^DDIOL("The following procedure(s) have been entered: ","","!")
+8 DO EN^DDIOL("","","!")
+9 SET AMERNO=0
+10 FOR
SET AMERNO=$ORDER(^AMERVSIT(AMERDA,4,AMERNO))
IF AMERNO="B"
QUIT
Begin DoDot:2
+11 SET Y=$GET(^AMERVSIT(AMERDA,4,AMERNO,0))
SET Y1=$GET(^AMER(3,Y,0))
+12 DO EN^DDIOL($PIECE(Y1,U,1),"","!")
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 DO EN^DDIOL("","","!")
+16 FOR
IF Y="^"
QUIT
Begin DoDot:1
+17 SET SKIP=0
+18 ;only show type 20 -ER PROCEDURES
SET DIC="^AMER(3,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)=20"
SET Y=""
+19 SET DIC("A")="Enter "_$SELECT($PIECE($GET(^AMERVSIT(AMERDA,4,0)),U,3)>0:"another ",1:"a ")_"procedure: "
+20 DO ^DIC
+21 IF $GET(Y)<=0
SET Y="^"
QUIT
+22 ;First look to see if that procedure has already been entered
+23 ;if it has, we give the user a chance to delete it
+24 SET AMERNO=0
+25 FOR
SET AMERNO=$ORDER(^AMERVSIT(AMERDA,4,AMERNO))
IF 'AMERNO
QUIT
IF ^AMERVSIT(AMERDA,4,AMERNO,0)=$PIECE(Y,U,1)
Begin DoDot:2
+26 SET SKIP=1
+27 SET AMEROLD=$GET(^AMERVSIT(AMERDA,4,AMERNO,0))
+28 SET DIR(0)="Y"
SET DIR("A")="Delete this procedure? "
SET DIR("B")="NO"
+29 DO ^DIR
+30 IF Y=1
Begin DoDot:3
+31 SET AMEREDNO=AMEREDNO+1
+32 SET AMERNEW=""
+33 SET AMERSTRG=$$EDAUDIT^AMEREDAU("4-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMEROLD,"R"),$$EDDISPL^AMEREDAU(AMERNEW,"R"),"PROCEDURE")
+34 IF AMERSTRG="^"
QUIT
+35 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+36 SET DA(1)=AMERDA
SET DA=AMERNO
SET DIK="^AMERVSIT(DA(1),4,"
+37 ;Kill the record and Re-index
DO ^DIK
DO EN^DIK
KILL DIK
+38 QUIT
End DoDot:3
+39 SET (AMERNO,Y)=""
+40 QUIT
End DoDot:2
+41 IF 'SKIP
Begin DoDot:2
+42 ; PROCEDURES
SET DA(1)=AMERDA
SET DIC="^AMERVSIT(DA(1),4,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9009080,4,0),U,2)
+43 SET AMEROLD=""
SET AMERNEW=+Y
+44 SET X="`"_+Y
+45 ;add a new entry
DO ^DIC
KILL DIC
+46 SET AMERNO=+Y
SET AMEREDNO=AMEREDNO+1
+47 SET AMERSTRG=$$EDAUDIT^AMEREDAU("4-1"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMEROLD,"R"),$$EDDISPL^AMEREDAU(AMERNEW,"R"),"PROCEDURE")
+48 IF AMERSTRG="^"
QUIT
+49 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+50 QUIT
End DoDot:2
+51 QUIT
End DoDot:1
+52 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+53 IF AMEREDTS'=""
DO MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
+54 KILL AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG
+55 QUIT 1
+56 ;
EDEXTAS(AMERDA,AMERAIEN) ;EP from AMEREDIT - ER EXIT ASSESSMENT
+1 ;QD12 - FINAL TRIAGE CATEGORY
+2 NEW Y,AMEROLD,AMERNEW,AMEREDTS,AMERDR,AMERSTRG,AMEROPTN,AMERFAC,AMERM,DIR,DIC,AMEROPNO
+3 SET (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,AMERDR,Y)=""
+4 SET AMEROLD=$PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,4)
+5 IF AMEROLD'=""
SET DIR("B")=AMEROLD
+6 SET DIR(0)="NO^1:5:0"
SET DIR("A")="Enter final acuity assessment from provider"
+7 SET DIR("?")="Enter a number from 1 to 5 - This is a required field"
+8 FOR
IF Y="^"
QUIT
Begin DoDot:1
+9 DO ^DIR
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
SET Y="^"
QUIT
+11 SET AMERNEW=Y
+12 IF AMERNEW=AMEROLD
SET Y="^"
QUIT
+13 IF AMERNEW>0
Begin DoDot:2
+14 SET AMERSTRG=$$EDAUDIT^AMEREDAU("4.1",AMEROLD,AMERNEW,"FINAL ACUITY")
+15 IF AMERSTRG="^"
QUIT
+16 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+17 SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"5.4///"_Y
+18 SET Y="^"
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+22 IF AMERDR'=""
Begin DoDot:1
+23 DO DIE^AMEREDIT(AMERDA,AMERDR)
+24 QUIT
End DoDot:1
+25 IF AMEREDTS'=""
DO MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
+26 SET (DR,AMEREDTS)=""
+27 ;QD14 - DISPOSITION and transfer
+28 SET AMEROPNO=""
+29 IF $PIECE($GET(^AMERVSIT(AMERDA,6)),U,1)'=""
SET (AMEROLD,AMEROPNO)=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,1)
+30 SET DIC("A")="Disposition: "
KILL DIC("B"),DIC("S")
+31 SET DIC="^AMER(3,"
SET DIC(0)="AEQ"
SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("DISPOSITION")
+32 IF AMEROPNO'=""
SET DIC("B")=$PIECE($GET(^AMER(3,AMEROPNO,0)),U,1)
+33 DO ^DIC
KILL DIC
+34 IF AMEROLD=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION")
Begin DoDot:1
+35 DO EN^DDIOL("This disposition can not be changed!!","","!")
+36 SET AMERNEW=AMEROLD
End DoDot:1
+37 IF '$TEST
SET AMERNEW=+Y
+38 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+39 ;IHS/OIT/SCR - 10/08/08 - START if the new value is Registered in error delete PCC VISIT
+40 IF (AMERNEW>0)
Begin DoDot:1
+41 IF AMERNEW=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION")
Begin DoDot:2
+42 DO EN^DDIOL("This DISPOSITION will cause this entire VISIT to be deleted!!","","!")
+43 SET DIR(0)="Y"
SET DIR("A")="Do you still wish to keep this DISPOSITION"
+44 SET DIR("B")="YES"
+45 DO ^DIR
+46 IF Y=0
SET AMERNEW=AMEROLD
+47 IF Y=1
Begin DoDot:3
+48 DO DELETVST^AMERVSIT(AMERDA)
+49 SET AMERDA=0
+50 QUIT
End DoDot:3
+51 ;IHS/OIT/SCR - 10/08/08 - END if the new value is Registered in error delete PCC VISIT
QUIT
End DoDot:2
+52 SET AMEROPTN=$$OPT^AMER0("TRANSFER","DISPOSITION")
+53 IF (AMERNEW'=AMEROLD)
Begin DoDot:2
+54 SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.1///"_AMERNEW
+55 SET AMERSTRG=$$EDAUDIT^AMEREDAU("6.1",$$EDDISPL^AMEREDAU(AMEROLD,"I"),$$EDDISPL^AMEREDAU(AMERNEW,"I"),"DISPOSITION")
+56 IF AMERSTRG="^"
QUIT
+57 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+58 ;If the old value was "transfer to another facility, delete facility associated
+59 IF AMEROLD=AMEROPTN
Begin DoDot:3
End DoDot:3
SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.6////@"
+60 QUIT
End DoDot:2
+61 IF AMERNEW=AMEROPTN
Begin DoDot:2
+62 ;IF the new value is "transfer to another facility", collect facility information
+63 DO EN^DDIOL("","","!")
+64 SET AMEROLD=""
+65 IF $PIECE($GET(^AMER(2.1,0)),U,3)=""
DO EN^DDIOL("No local ER Facilities found","","!")
QUIT
+66 SET DIC="^AMER(2.1,"
SET DIC(0)="AEQM"
+67 SET DIC("A")="Where is patient being transferred? "
+68 SET AMERFAC=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,6)
+69 IF AMERFAC'=""
SET (DIC("B"),AMEROLD)=$PIECE($GET(^AMER(2.1,AMERFAC,0)),U,1)
+70 IF '$TEST
SET AMERM=$ORDER(^AMER(2.1,0))
+71 DO ^DIC
KILL DIC
+72 IF +Y>0
SET AMERNEW=$PIECE($GET(^AMER(2.1,+Y,0)),U,1)
+73 IF '$TEST
SET AMERNEW=""
+74 IF +Y>0&(AMERNEW'=AMEROLD)
Begin DoDot:3
+75 SET AMERDR=$SELECT(AMERDR'="":AMERDR_";",1:"")
SET AMERDR=AMERDR_"6.6////"_+Y
+76 SET AMERSTRG=$$EDAUDIT^AMEREDAU("6.6",AMEROLD,AMERNEW,"TRANSFER TO")
+77 IF AMERSTRG="^"
QUIT
+78 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+79 QUIT
End DoDot:3
+80 QUIT
+81 IF '$TEST
IF AMEROPTN<0
Begin DoDot:3
+82 DO EN^DDIOL("Option 'TRANSFER TO ANOTHER FACILITY' is missing ","","!")
+83 DO EN^DDIOL("This DISPOSITION type is required for collection of transfer location ","","!")
+84 QUIT
End DoDot:3
+85 QUIT
End DoDot:2
+86 IF AMEROLD=AMEROPTN
+87 ;IF NEW>0
QUIT
End DoDot:1
+88 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+89 IF AMERDR'=""
Begin DoDot:1
+90 DO DIE^AMEREDIT(AMERDA,AMERDR)
+91 QUIT
End DoDot:1
+92 IF AMEREDTS'=""
DO MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
+93 KILL Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DR,AMERDR,AMEROPTN,AMERFAC,AMERM,DIR,DIC
+94 QUIT 1
+95 ;
EDFUINST(AMERDA,AMERAIEN) ;EP - From AMEREDIT
+1 ;QD16 - DISCHARGE INSTRUCTIONS
+2 NEW FIIEN,CNT,FI,DIR,%,AMEROLD
+3 ;
+4 ;Get the default entry
+5 SET AMEROLD=$$GET1^DIQ(9009080,AMERDA_",",7,"I")
IF AMEROLD]""
SET DIR("B")=$$GET1^DIQ(9009083,AMEROLD_",",.01,"I")
+6 ;
+7 SET CNT=0
+8 SET DIR(0)="SO^"
+9 SET FIIEN=$ORDER(^AMER(2,"B","FOLLOW UP INSTRUCTIONS",""))
+10 SET FI=""
FOR
SET FI=$ORDER(^AMER(3,"AC",FIIEN,FI))
IF FI=""
QUIT
Begin DoDot:1
+11 SET CNT=CNT+1
+12 SET INSNM=$$GET1^DIQ(9009083,FI_",",".01","I")
IF INSNM=""
QUIT
+13 SET INS(CNT)=INSNM_U_FI
+14 SET DIR(0)=DIR(0)_$SELECT(CNT>1:";",1:"")_CNT_":"_INSNM
End DoDot:1
+15 ;
+16 SET DIR("A")="Follow up instructions"
+17 DO ^DIR
+18 ;
+19 ;Process invalid entries
+20 ;I +Y<1,X'="@" S X="^",Y="^" D OUT^AMER Q
+21 ;
+22 ;Handle proper selection
+23 IF +Y>0
SET Y=$PIECE(INS(+Y),U,2)
+24 ;
+25 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT 0
+26 SET AMERNEW=$SELECT(+Y>0:+Y,1:"")
+27 ;
+28 ;Save/Audit
+29 IF AMERNEW'=AMEROLD
Begin DoDot:1
+30 NEW AMERSTRG,DR
+31 SET AMERSTRG=$$EDAUDIT^AMEREDAU("7",$$EDDISPL^AMEREDAU(AMEROLD,"F"),$$EDDISPL^AMEREDAU(AMERNEW,"F"),"DISCHARGE INSTRUCTIONS")
+32 SET DR="7////"_$SELECT(AMERNEW]"":AMERNEW,1:"@")
+33 DO DIE^AMEREDIT(AMERDA,DR)
+34 IF AMERSTRG="^"
QUIT
+35 DO DIEREC^AMEREDAU(AMERAIEN,AMERSTRG)
End DoDot:1
+36 ;
+37 QUIT 1
