AMER2A ; IHS/ANMC/GIS -ISC - OVERFLOW FROM AMER2 ;
;;3.0;ER VISIT SYSTEM;**6,10**;MAR 03, 2009;Build 23
;
QD20 ; CLINIC TYPE
N AMERLINE,%
I '$D(AMERMAND),'$D(AMEREFLG),'$D(^TMP("AMER",$J,2,20)),'$D(AMERBCH) D
.S %="",$P(%,"~",80)="",AMERLINE=%
.W @IOF,"ER ADMISSION FOR ",$P(^DPT(AMERDFN,0),U)," ^ = back up ^^ = quit"
.W !,"Questions preceded by a '*' are MANDATORY. Enter '??' to see choices."
.W !,AMERLINE,!
.Q
QD20A ;
N AMERPCC,AMERLOC,AMERCLN,AMERTYP,ERR
S X=""
;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Pull default clinic and use
;S DIC("A")="*Clinic type (EMERGENCY or URGENT): " K DIC("B")
S DIC("A")="*Clinic type: " K DIC("B")
;S DIC("B")="EMERGENCY MEDICINE"
;IHS/OIT/SCR 2/20/09 - DEFAULT TO WALK IN CLINIC THAT IS IDENTIFIED IN ERS SITE PREFERENCES FILE
;S AMERLOC=0,AMERLOC=$O(^AMER(2.5,AMERLOC))
S AMERLOC=$G(DUZ(2))
I '$D(^AMER(2.5,AMERLOC,0)) D
.W !,"SITE PARAMETERS have not been set up in the ERS PARAMETER option"
.W !,"Please contact your ERS Supervisors to complete this option before using the EMERGENCY ROOM system"
.S X="^^"
.Q
I AMERLOC'="" D
.;
.;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Pull default clinic and use
.S DIC("B")=""
.S AMERCLN=$$GET1^DIQ(9009082.5,AMERLOC_",",.06,"I") I AMERCLN]"" D
..S DIC("B")=$$GET1^DIQ(9009083,AMERCLN,.01,"E")
.;If not defined use first one with 30
.I DIC("B")="" D
..S AMERCLN=$O(^AMER(3,"B",30,""))
..I AMERCLN]"" S DIC("B")=$$GET1^DIQ(9009083,AMERCLN,.01,"E")
.;
.;I AMERCLN'="" D
.;.S AMERTYP=$P(^SC(AMERCLN,0),"^",7) ;THIS STOP CODE NUMBER - POINTER TO STOP CODE FILE (30 OR 60)
.;.S DIC("B")=AMERTYP
.;.S AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
.;.S:AMERPCC>0 DIC("B")=$$GET1^DIQ(9000010,AMERPCC,.08)
.S AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
.I AMERPCC>0 D
..S AMERCLN=$$GETCLN(AMERPCC) ;Pull Hospital Location
..I AMERCLN]"" S DIC("B")=$$GET1^DIQ(9009083,AMERCLN,.01,"E") ;Get AMER clinic text
..I $D(^TMP("AMER",$J,2,20)) S %=+^(20),DIC("B")=$P(^AMER(3,%,0),U) ;clinic code
..S DIC="^AMER(3,"
..;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Filter out inactive
..;S DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("CLINIC TYPE")
..S DIC("S")="I '$P(^(0),U,5),$P(^(0),U,2)="_$$CAT^AMER0("CLINIC TYPE")
..S DIC(0)="AEQ"
..D ^DIC K DIC
..I X=U,'$D(AMERBCH),'$D(AMEREFLG) S X="^^"
..I X=U,$D(AMEREFLG) S AMERTFLG=""
..I X=U Q
..Q
.Q
;
;GDIT/HS/BEE 05/10/2018;CR#10213/10423 - AMER*3.0*10 - Save updated clinic and hospital location
;Need to update clinic and hospital location if overrides on file and possibly create new appt
I +Y,AMERPCC>0 S ERR=$$CKHLOC^AMERBSD(AMERPCC,+Y)
;
D OUT^AMER I $D(AMERQUIT) Q
Q
;
QD21 ; PROVIDER
;IHS/OIT/SCR 10/31/08 don't ask if we are in TRIAGE
;IHS/OIT/SCR 01/06/09 WHERE OH WHERE DOES THIS Y COME FROM?
;Q:$G(AMERTRG)=1
I $G(AMERTRG)=1 D Q
.S Y=-1
.Q
;S DIC("A")="*Admitting physician: " K DIC("B")
;IHS/OIT/SCR 01/20/09 - removed asterik since this is no longer considered mandatory
S DIC("A")="ED Provider: " K DIC("B")
S DIC("?")="Only active providers can be selected"
;I $D(^TMP("AMER",$J,2,21)) S %=+^(21),DIC("B")=$P(^VA(200,%,0),U)
I $D(^TMP("AMER",$J,2,21))&($G(^TMP("AMER",$J,2,21))>1) S %=+^(21),DIC("B")=$P(^VA(200,%,0),U)
S DIC="^VA(200,",DIC(0)="AEQM"
;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))"
D ^DIC K DIC
I $G(Y)'>0 K ^TMP("AMER",$J,2,24)
D OUT^AMER I $D(AMERQUIT) Q
Q
;
QD22 ; TRIAGE NURSE
S DIC("A")="*Triage nurse: " K DIC("B")
I $D(^TMP("AMER",$J,2,22)) S %=+^(22),DIC("B")=$P(^VA(200,%,0),U)
S DIC("?")="Only active providers can be selected"
S DIC="^VA(200,",DIC(0)="AEQM"
;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))"
D ^DIC K DIC
I $G(Y)'>0 K ^TMP("AMER",$J,2,25)
D OUT^AMER I $D(AMERQUIT) Q
Q
;
QD23 ; INITIAL TRIAGE
S DIR("B")=$G(^TMP("AMER",$J,2,23))
S DIR("?")="Enter a number from 1 to 5"
S DIR("?",1)="This is a site-specified value that indicates severity of visit"
S DIR(0)="N^1:5:0",DIR("A")="*Enter initial triage assessment from RN" KILL DA D ^DIR KILL DIR
D OUT^AMER I X=U Q
I '$D(^TMP("AMER",$J,2,21)),'$D(^(22)),'$G(^TMP("AMER",$J,1,21)),'$D(AMEREFLG) S AMERSTRT=1,AMERFIN=27,AMERRUN=$S('$D(AMERTRG):1,$D(AMERTRG):30) Q
I '$D(^TMP("AMER",$J,2,22)),$D(^(21)) S AMERRUN=24 Q
I '$D(^TMP("AMER",$J,2,22)) S AMERRUN=25
Q
;
QD24 ; TRIAGE TIME
I $D(^TMP("AMER",$J,2,24)) S Y=^(24) X ^DD("DD") S DIR("B")=Y
;IHS/OIT/SCR 01/20/09 field no longer manditory
;S DIR(0)="DO^::ER",DIR("A")="What time did the patient see the triage nurse",DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)" D ^DIR K DIR
S DIR(0)="D^::ER",DIR("A")="*What time did the patient see the triage nurse",DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)" D ^DIR K DIR
I Y,$$TCK($G(^TMP("AMER",$J,1,2)),Y,1,"admission") K Y G QD24
I Y,$$TVAL($G(^TMP("AMER",$J,1,2)),Y,2) K Y G QD24
I Y="" S Y=-1
D OUT^AMER I X?1."^" Q
I '$D(^TMP("AMER",$J,2,21)),'$G(^TMP("AMER",$J,1,21)),'$D(AMEREFLG) S AMERFIN=28,AMERSTRT=1,AMERRUN=27 Q
I '$D(^TMP("AMER",$J,2,21)) S AMERRUN=25 Q
Q
;
QD25 ; DOC TIME
;IHS/OIT/SCR 10/31/08 DON'T ASK DOC TIME IF WE ARE USING TRIAGE OPTION
;Q:$G(AMERTRG)=1
I $G(AMERTRG)=1 D Q
.S Y=-1
.Q
;IHS/OIT/SCR 11/21/08 don't default the doc time in OUT
;I $D(^TMP("AMER",$J,2,25)) S Y=^(25) X ^DD("DD") S DIR("B")=Y
S DIR(0)="D^::ER",DIR("A")="*What was the ED Provider Medical Screening Exam Time",DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)" D ^DIR K DIR
I Y,$$TCK($G(^TMP("AMER",$J,1,2)),Y,1,"admission") K Y G QD25
I Y,$$TCK($G(^TMP("AMER",$J,2,24)),Y,1,"triage") K Y G QD25
I Y,$$TVAL($G(^TMP("AMER",$J,1,2)),Y,4) K Y G QD25
I Y="" S Y=-1
Q:Y=-1
D OUT^AMER I X?1."^" Q
S AMERFIN=28,AMERRUN=27 Q
;I '$D(AMERTRG) S AMERRUN=1
;I $D(AMEREFLG) S AMERRUN=30
Q
;
QD28(AMERPCC) ; Decision to admit date/time - AMER*3.0*6
NEW DIR,DECDT,PCCUPD,ERROR,AMVDT
;
QD28E ;Pull current date/time from PCC
I $G(AMERPCC)="" S AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
I AMERPCC="" S AMERRUN=1 Q
S DECDT=$$GET1^DIQ(9000010,AMERPCC,1116,"E")
S:$G(DECDT)]"" DIR("B")=DECDT
S AMVDT=$$GET1^DIQ(9000010,AMERPCC_",",.01,"I") ;Get visit date
;
;Prompt for date
S DIR(0)="DO^::ER",DIR("A")="Enter the decision to admit date/time",DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)" D ^DIR K DIR
;
;Perform validation
I Y,$$TCK(AMVDT,Y,1,"admission") K Y G QD28E
;
;Save the new value
I +Y>0 S PCCUPD(9000010,AMERPCC_",",1116)=Y
;
;Handle deletes
I Y="" S PCCUPD(9000010,AMERPCC_",",1116)="@"
;
;File entry in PCC
I $D(PCCUPD) D FILE^DIE("","PCCUPD","ERROR")
;
I '$G(^TMP("AMER",$J,1,21)),'$D(AMEREFLG) S AMERFIN=28,AMERSTRT=1,AMERRUN=$S('$D(AMERTRG):1,$D(AMERTRG):30,1:1) Q
I '$D(AMERTRG) S AMERRUN=1
S AMERRUN=1
Q
;
TCK(Z,T,X,A) ; ENTRY POINT FROM AMER2
; TIME CHECK WHERE Z=TIME,T=COMPARISON TIME,X=1:AFTER,X=0:BEFORE AND A=NARRATIVE
N %,Y
I $G(Z)=""!($G(A)="") Q ""
S Y=Z X ^DD("DD")
I X,T'<Z Q 0
I 'X,T<Z Q 0
W !!,*7,"Sorry, this time must be ",$S(X:"AFTER",1:"BEFORE")," the time of ",A,": ",Y,!,"Please try again...",! Q 1
;
TVAL(Z,T,H) ; ENTRY POINT FROM AMER2 and multiple editing routines
; VALIDATE THE TIME WHERE Z=TIME,T=COMPARISON TIME AND H=MAX HOURS ALLOWED
N A,B,C,D,X,%H,%T,%Y,%,E,F,Y
S Y=Z X ^DD("DD")
S X=Z D H^%DTC S A=%H,B=%T
S X=T D H^%DTC S C=%H,D=%T
S E=C-A*60*60*24+D
S F=(E-B)\(3600)
I F<H Q 0
S %=2 W !!,*7,"This means a really long delay since the time of admission: ",Y,!,"Are you sure" D YN^DICN W !
I %=1 Q 0
Q 1
;
;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Save updated clinic and hospital location
SYNCCL(AMERDA,AMERPCC) ;Sync the ER VISIT clinic with the PCC clinic
;
;Original code from SYNCHPCC^AMERPCC - Copied here to address routine size issue
; GET THE EXTERNAL VALUE FOR "CLINIC TYPE" IN VISIT FILE AND SET IT TO EMERGENCY IF IT ISN'T ALREADY URGENT CARE
;S AMERCLN=$P($G(^AMERVSIT(AMERDA,0)),U,4) ; AMERCLN IS A POINTER TO ER OPTIONS FILE
;I AMERCLN'="" D
;.S AMERCLN=$P($G(^AMER(3,AMERCLN,0)),U,1) ; AMERCLN IS A WORD - 30: EMERGENCY MEDICINE "80: URGENT CARE"
;.S AMERVVAL=$$CLINIC^APCLV(AMERPCC,"E")
;.I (AMERVVAL'=AMERCLN) D
;..S AMERPNTR=$O(^DIC(40.7,"B",AMERCLN,0))
;..S:AMERPNTR'="" AMERVDR=$S(AMERVDR'="":AMERVDR_";",1:""),AMERVDR=AMERVDR_".08////"_AMERPNTR
;..Q
;
I +$G(AMERDA)=0 Q
I +$G(AMERPCC)=0 Q
;
NEW ECEIEN,ECPIEN,EHPIEN,PCIEN,PHIEN
;
;Get ERS clinic pointer to ER OPTIONS
S ECEIEN=$$GET1^DIQ(9009080,AMERDA_",",.04,"I")
;
;Get ERS clinic pointer associated IEN for PCC and associated hospital location IEN
S (ECPIEN,EHPIEN)="" I +ECEIEN D
. NEW CLN,HLI
. ;
. ;Clinic
. S CLN=$$GET1^DIQ(9009083,+ECEIEN_",",5,"I") ;Get clinic code
. I CLN]"" S ECPIEN=$O(^DIC(40.7,"C",CLN,""))
. ;
. ;Hospital Location
. S HLI=$O(^AMER(2.5,DUZ(2),8,"B",+ECEIEN,"")) I HLI D
.. S EHPIEN=$P($G(^AMER(2.5,DUZ(2),8,HLI,0)),U,2)
. S:EHPIEN="" EHPIEN=$G(^AMER(2.5,DUZ(2),"SD")) ;If blank, pull original value
;
;Get PCC Clinic and Hospital Location
S PCIEN=$$GET1^DIQ(9000010,AMERPCC_",",.08,"I")
S PHIEN=$$GET1^DIQ(9000010,AMERPCC_",",.22,"I")
;
;If ER VISIT is blank or not equal to PCC copy from PCC
I PCIEN,(('ECEIEN)!(ECPIEN'=PCIEN)) D Q
. NEW AMERUPD,ERROR,ENCPIEN,CODE
. S CODE=$$GET1^DIQ(40.7,PCIEN_",",1,"I") Q:'CODE
. S ENCPIEN=$O(^AMER(3,"B",CODE,"")) Q:'ENCPIEN
. S AMERUPD(9009080,AMERDA_",",.04)=ENCPIEN
. D FILE^DIE("","AMERUPD","ERROR")
;
;If PCC is blank copy from ER VISIT
I 'PCIEN,ECPIEN D
. NEW AMERUPD,ERROR
. S AMERUPD(9000010,AMERPCC_",",.08)=ECPIEN
. S AMERUPD(9000010,AMERPCC_",",.22)=EHPIEN
. D FILE^DIE("","AMERUPD","ERROR")
;
Q
;
;GDIT/HS/BEE 07/12/2018;CR#10423 - AMER*3.0*10
GETCLN(AUPNVSIT) ;Return the ER Clinic for the PCC hospital location
;
I $G(AUPNVSIT)="" Q ""
;
NEW HLOC,CLN,DIV
;
S DIV=$$GET1^DIQ(9000010,AUPNVSIT_",",".06","I") S:DIV="" DIV=$G(DUZ(2)) I DIV="" Q ""
;
S CLN=""
S HLOC=$$GET1^DIQ(9000010,AUPNVSIT_",",.22,"I") I HLOC]"" D
. NEW CIEN
. S CIEN=0 F S CIEN=$O(^AMER(2.5,DIV,8,CIEN)) Q:'CIEN D Q:CLN
.. NEW ECLN,EHLOC,DA,IENS
.. S DA(1)=DIV,DA=CIEN,IENS=$$IENS^DILF(.DA)
.. S EHLOC=$$GET1^DIQ(9009082.58,IENS_",",".02","I")
.. I HLOC'=EHLOC Q
.. S ECLN=$$GET1^DIQ(9009082.58,IENS_",",".01","I") Q:ECLN=""
.. S CLN=ECLN
;
;If no clinic resort to pre-patch 10 logic
I CLN="" D
. NEW CLINIC
. ;
. S CLINIC=$$GET1^DIQ(9000010,AUPNVSIT_",",.08,"I")
. I CLINIC]"" S CLINIC=$$GET1^DIQ(40.7,CLINIC_",",1,"I")
. I CLINIC]"" S CLN=$O(^AMER(3,"B",CLINIC,""))
;
Q CLN
AMER2A ; IHS/ANMC/GIS -ISC - OVERFLOW FROM AMER2 ;
+1 ;;3.0;ER VISIT SYSTEM;**6,10**;MAR 03, 2009;Build 23
+2 ;
QD20 ; CLINIC TYPE
+1 NEW AMERLINE,%
+2 IF '$DATA(AMERMAND)
IF '$DATA(AMEREFLG)
IF '$DATA(^TMP("AMER",$JOB,2,20))
IF '$DATA(AMERBCH)
Begin DoDot:1
+3 SET %=""
SET $PIECE(%,"~",80)=""
SET AMERLINE=%
+4 WRITE @IOF,"ER ADMISSION FOR ",$PIECE(^DPT(AMERDFN,0),U)," ^ = back up ^^ = quit"
+5 WRITE !,"Questions preceded by a '*' are MANDATORY. Enter '??' to see choices."
+6 WRITE !,AMERLINE,!
+7 QUIT
End DoDot:1
QD20A ;
+1 NEW AMERPCC,AMERLOC,AMERCLN,AMERTYP,ERR
+2 SET X=""
+3 ;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Pull default clinic and use
+4 ;S DIC("A")="*Clinic type (EMERGENCY or URGENT): " K DIC("B")
+5 SET DIC("A")="*Clinic type: "
KILL DIC("B")
+6 ;S DIC("B")="EMERGENCY MEDICINE"
+7 ;IHS/OIT/SCR 2/20/09 - DEFAULT TO WALK IN CLINIC THAT IS IDENTIFIED IN ERS SITE PREFERENCES FILE
+8 ;S AMERLOC=0,AMERLOC=$O(^AMER(2.5,AMERLOC))
+9 SET AMERLOC=$GET(DUZ(2))
+10 IF '$DATA(^AMER(2.5,AMERLOC,0))
Begin DoDot:1
+11 WRITE !,"SITE PARAMETERS have not been set up in the ERS PARAMETER option"
+12 WRITE !,"Please contact your ERS Supervisors to complete this option before using the EMERGENCY ROOM system"
+13 SET X="^^"
+14 QUIT
End DoDot:1
+15 IF AMERLOC'=""
Begin DoDot:1
+16 ;
+17 ;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Pull default clinic and use
+18 SET DIC("B")=""
+19 SET AMERCLN=$$GET1^DIQ(9009082.5,AMERLOC_",",.06,"I")
IF AMERCLN]""
Begin DoDot:2
+20 SET DIC("B")=$$GET1^DIQ(9009083,AMERCLN,.01,"E")
End DoDot:2
+21 ;If not defined use first one with 30
+22 IF DIC("B")=""
Begin DoDot:2
+23 SET AMERCLN=$ORDER(^AMER(3,"B",30,""))
+24 IF AMERCLN]""
SET DIC("B")=$$GET1^DIQ(9009083,AMERCLN,.01,"E")
End DoDot:2
+25 ;
+26 ;I AMERCLN'="" D
+27 ;.S AMERTYP=$P(^SC(AMERCLN,0),"^",7) ;THIS STOP CODE NUMBER - POINTER TO STOP CODE FILE (30 OR 60)
+28 ;.S DIC("B")=AMERTYP
+29 ;.S AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
+30 ;.S:AMERPCC>0 DIC("B")=$$GET1^DIQ(9000010,AMERPCC,.08)
+31 SET AMERPCC=$$EXISTING^AMERPCC(AMERDFN)
+32 IF AMERPCC>0
Begin DoDot:2
+33 ;Pull Hospital Location
SET AMERCLN=$$GETCLN(AMERPCC)
+34 ;Get AMER clinic text
IF AMERCLN]""
SET DIC("B")=$$GET1^DIQ(9009083,AMERCLN,.01,"E")
+35 ;clinic code
IF $DATA(^TMP("AMER",$JOB,2,20))
SET %=+^(20)
SET DIC("B")=$PIECE(^AMER(3,%,0),U)
+36 SET DIC="^AMER(3,"
+37 ;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Filter out inactive
+38 ;S DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("CLINIC TYPE")
+39 SET DIC("S")="I '$P(^(0),U,5),$P(^(0),U,2)="_$$CAT^AMER0("CLINIC TYPE")
+40 SET DIC(0)="AEQ"
+41 DO ^DIC
KILL DIC
+42 IF X=U
IF '$DATA(AMERBCH)
IF '$DATA(AMEREFLG)
SET X="^^"
+43 IF X=U
IF $DATA(AMEREFLG)
SET AMERTFLG=""
+44 IF X=U
QUIT
+45 QUIT
End DoDot:2
+46 QUIT
End DoDot:1
+47 ;
+48 ;GDIT/HS/BEE 05/10/2018;CR#10213/10423 - AMER*3.0*10 - Save updated clinic and hospital location
+49 ;Need to update clinic and hospital location if overrides on file and possibly create new appt
+50 IF +Y
IF AMERPCC>0
SET ERR=$$CKHLOC^AMERBSD(AMERPCC,+Y)
+51 ;
+52 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+53 QUIT
+54 ;
QD21 ; PROVIDER
+1 ;IHS/OIT/SCR 10/31/08 don't ask if we are in TRIAGE
+2 ;IHS/OIT/SCR 01/06/09 WHERE OH WHERE DOES THIS Y COME FROM?
+3 ;Q:$G(AMERTRG)=1
+4 IF $GET(AMERTRG)=1
Begin DoDot:1
+5 SET Y=-1
+6 QUIT
End DoDot:1
QUIT
+7 ;S DIC("A")="*Admitting physician: " K DIC("B")
+8 ;IHS/OIT/SCR 01/20/09 - removed asterik since this is no longer considered mandatory
+9 SET DIC("A")="ED Provider: "
KILL DIC("B")
+10 SET DIC("?")="Only active providers can be selected"
+11 ;I $D(^TMP("AMER",$J,2,21)) S %=+^(21),DIC("B")=$P(^VA(200,%,0),U)
+12 IF $DATA(^TMP("AMER",$JOB,2,21))&($GET(^TMP("AMER",$JOB,2,21))>1)
SET %=+^(21)
SET DIC("B")=$PIECE(^VA(200,%,0),U)
+13 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+14 ;screening so that only valid PCC providers identified
+15 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+16 DO ^DIC
KILL DIC
+17 IF $GET(Y)'>0
KILL ^TMP("AMER",$JOB,2,24)
+18 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+19 QUIT
+20 ;
QD22 ; TRIAGE NURSE
+1 SET DIC("A")="*Triage nurse: "
KILL DIC("B")
+2 IF $DATA(^TMP("AMER",$JOB,2,22))
SET %=+^(22)
SET DIC("B")=$PIECE(^VA(200,%,0),U)
+3 SET DIC("?")="Only active providers can be selected"
+4 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+5 ;screening so that only valid PCC providers identified
+6 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+7 DO ^DIC
KILL DIC
+8 IF $GET(Y)'>0
KILL ^TMP("AMER",$JOB,2,25)
+9 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+10 QUIT
+11 ;
QD23 ; INITIAL TRIAGE
+1 SET DIR("B")=$GET(^TMP("AMER",$JOB,2,23))
+2 SET DIR("?")="Enter a number from 1 to 5"
+3 SET DIR("?",1)="This is a site-specified value that indicates severity of visit"
+4 SET DIR(0)="N^1:5:0"
SET DIR("A")="*Enter initial triage assessment from RN"
KILL DA
DO ^DIR
KILL DIR
+5 DO OUT^AMER
IF X=U
QUIT
+6 IF '$DATA(^TMP("AMER",$JOB,2,21))
IF '$DATA(^(22))
IF '$GET(^TMP("AMER",$JOB,1,21))
IF '$DATA(AMEREFLG)
SET AMERSTRT=1
SET AMERFIN=27
SET AMERRUN=$SELECT('$DATA(AMERTRG):1,$DATA(AMERTRG):30)
QUIT
+7 IF '$DATA(^TMP("AMER",$JOB,2,22))
IF $DATA(^(21))
SET AMERRUN=24
QUIT
+8 IF '$DATA(^TMP("AMER",$JOB,2,22))
SET AMERRUN=25
+9 QUIT
+10 ;
QD24 ; TRIAGE TIME
+1 IF $DATA(^TMP("AMER",$JOB,2,24))
SET Y=^(24)
XECUTE ^DD("DD")
SET DIR("B")=Y
+2 ;IHS/OIT/SCR 01/20/09 field no longer manditory
+3 ;S DIR(0)="DO^::ER",DIR("A")="What time did the patient see the triage nurse",DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)" D ^DIR K DIR
+4 SET DIR(0)="D^::ER"
SET DIR("A")="*What time did the patient see the triage nurse"
SET DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)"
DO ^DIR
KILL DIR
+5 IF Y
IF $$TCK($GET(^TMP("AMER",$JOB,1,2)),Y,1,"admission")
KILL Y
GOTO QD24
+6 IF Y
IF $$TVAL($GET(^TMP("AMER",$JOB,1,2)),Y,2)
KILL Y
GOTO QD24
+7 IF Y=""
SET Y=-1
+8 DO OUT^AMER
IF X?1."^"
QUIT
+9 IF '$DATA(^TMP("AMER",$JOB,2,21))
IF '$GET(^TMP("AMER",$JOB,1,21))
IF '$DATA(AMEREFLG)
SET AMERFIN=28
SET AMERSTRT=1
SET AMERRUN=27
QUIT
+10 IF '$DATA(^TMP("AMER",$JOB,2,21))
SET AMERRUN=25
QUIT
+11 QUIT
+12 ;
QD25 ; DOC TIME
+1 ;IHS/OIT/SCR 10/31/08 DON'T ASK DOC TIME IF WE ARE USING TRIAGE OPTION
+2 ;Q:$G(AMERTRG)=1
+3 IF $GET(AMERTRG)=1
Begin DoDot:1
+4 SET Y=-1
+5 QUIT
End DoDot:1
QUIT
+6 ;IHS/OIT/SCR 11/21/08 don't default the doc time in OUT
+7 ;I $D(^TMP("AMER",$J,2,25)) S Y=^(25) X ^DD("DD") S DIR("B")=Y
+8 SET DIR(0)="D^::ER"
SET DIR("A")="*What was the ED Provider Medical Screening Exam Time"
SET DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)"
DO ^DIR
KILL DIR
+9 IF Y
IF $$TCK($GET(^TMP("AMER",$JOB,1,2)),Y,1,"admission")
KILL Y
GOTO QD25
+10 IF Y
IF $$TCK($GET(^TMP("AMER",$JOB,2,24)),Y,1,"triage")
KILL Y
GOTO QD25
+11 IF Y
IF $$TVAL($GET(^TMP("AMER",$JOB,1,2)),Y,4)
KILL Y
GOTO QD25
+12 IF Y=""
SET Y=-1
+13 IF Y=-1
QUIT
+14 DO OUT^AMER
IF X?1."^"
QUIT
+15 SET AMERFIN=28
SET AMERRUN=27
QUIT
+16 ;I '$D(AMERTRG) S AMERRUN=1
+17 ;I $D(AMEREFLG) S AMERRUN=30
+18 QUIT
+19 ;
QD28(AMERPCC) ; Decision to admit date/time - AMER*3.0*6
+1 NEW DIR,DECDT,PCCUPD,ERROR,AMVDT
+2 ;
QD28E ;Pull current date/time from PCC
+1 IF $GET(AMERPCC)=""
SET AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
+2 IF AMERPCC=""
SET AMERRUN=1
QUIT
+3 SET DECDT=$$GET1^DIQ(9000010,AMERPCC,1116,"E")
+4 IF $GET(DECDT)]""
SET DIR("B")=DECDT
+5 ;Get visit date
SET AMVDT=$$GET1^DIQ(9000010,AMERPCC_",",.01,"I")
+6 ;
+7 ;Prompt for date
+8 SET DIR(0)="DO^::ER"
SET DIR("A")="Enter the decision to admit date/time"
SET DIR("?")="Enter an exact date and time in Fileman format (e.g. T@1PM)"
DO ^DIR
KILL DIR
+9 ;
+10 ;Perform validation
+11 IF Y
IF $$TCK(AMVDT,Y,1,"admission")
KILL Y
GOTO QD28E
+12 ;
+13 ;Save the new value
+14 IF +Y>0
SET PCCUPD(9000010,AMERPCC_",",1116)=Y
+15 ;
+16 ;Handle deletes
+17 IF Y=""
SET PCCUPD(9000010,AMERPCC_",",1116)="@"
+18 ;
+19 ;File entry in PCC
+20 IF $DATA(PCCUPD)
DO FILE^DIE("","PCCUPD","ERROR")
+21 ;
+22 IF '$GET(^TMP("AMER",$JOB,1,21))
IF '$DATA(AMEREFLG)
SET AMERFIN=28
SET AMERSTRT=1
SET AMERRUN=$SELECT('$DATA(AMERTRG):1,$DATA(AMERTRG):30,1:1)
QUIT
+23 IF '$DATA(AMERTRG)
SET AMERRUN=1
+24 SET AMERRUN=1
+25 QUIT
+26 ;
TCK(Z,T,X,A) ; ENTRY POINT FROM AMER2
+1 ; TIME CHECK WHERE Z=TIME,T=COMPARISON TIME,X=1:AFTER,X=0:BEFORE AND A=NARRATIVE
+2 NEW %,Y
+3 IF $GET(Z)=""!($GET(A)="")
QUIT ""
+4 SET Y=Z
XECUTE ^DD("DD")
+5 IF X
IF T'<Z
QUIT 0
+6 IF 'X
IF T<Z
QUIT 0
+7 WRITE !!,*7,"Sorry, this time must be ",$SELECT(X:"AFTER",1:"BEFORE")," the time of ",A,": ",Y,!,"Please try again...",!
QUIT 1
+8 ;
TVAL(Z,T,H) ; ENTRY POINT FROM AMER2 and multiple editing routines
+1 ; VALIDATE THE TIME WHERE Z=TIME,T=COMPARISON TIME AND H=MAX HOURS ALLOWED
+2 NEW A,B,C,D,X,%H,%T,%Y,%,E,F,Y
+3 SET Y=Z
XECUTE ^DD("DD")
+4 SET X=Z
DO H^%DTC
SET A=%H
SET B=%T
+5 SET X=T
DO H^%DTC
SET C=%H
SET D=%T
+6 SET E=C-A*60*60*24+D
+7 SET F=(E-B)\(3600)
+8 IF F<H
QUIT 0
+9 SET %=2
WRITE !!,*7,"This means a really long delay since the time of admission: ",Y,!,"Are you sure"
DO YN^DICN
WRITE !
+10 IF %=1
QUIT 0
+11 QUIT 1
+12 ;
+13 ;GDIT/HS/BEE 05/10/2018;CR#10213 - AMER*3.0*10 - Save updated clinic and hospital location
SYNCCL(AMERDA,AMERPCC) ;Sync the ER VISIT clinic with the PCC clinic
+1 ;
+2 ;Original code from SYNCHPCC^AMERPCC - Copied here to address routine size issue
+3 ; GET THE EXTERNAL VALUE FOR "CLINIC TYPE" IN VISIT FILE AND SET IT TO EMERGENCY IF IT ISN'T ALREADY URGENT CARE
+4 ;S AMERCLN=$P($G(^AMERVSIT(AMERDA,0)),U,4) ; AMERCLN IS A POINTER TO ER OPTIONS FILE
+5 ;I AMERCLN'="" D
+6 ;.S AMERCLN=$P($G(^AMER(3,AMERCLN,0)),U,1) ; AMERCLN IS A WORD - 30: EMERGENCY MEDICINE "80: URGENT CARE"
+7 ;.S AMERVVAL=$$CLINIC^APCLV(AMERPCC,"E")
+8 ;.I (AMERVVAL'=AMERCLN) D
+9 ;..S AMERPNTR=$O(^DIC(40.7,"B",AMERCLN,0))
+10 ;..S:AMERPNTR'="" AMERVDR=$S(AMERVDR'="":AMERVDR_";",1:""),AMERVDR=AMERVDR_".08////"_AMERPNTR
+11 ;..Q
+12 ;
+13 IF +$GET(AMERDA)=0
QUIT
+14 IF +$GET(AMERPCC)=0
QUIT
+15 ;
+16 NEW ECEIEN,ECPIEN,EHPIEN,PCIEN,PHIEN
+17 ;
+18 ;Get ERS clinic pointer to ER OPTIONS
+19 SET ECEIEN=$$GET1^DIQ(9009080,AMERDA_",",.04,"I")
+20 ;
+21 ;Get ERS clinic pointer associated IEN for PCC and associated hospital location IEN
+22 SET (ECPIEN,EHPIEN)=""
IF +ECEIEN
Begin DoDot:1
+23 NEW CLN,HLI
+24 ;
+25 ;Clinic
+26 ;Get clinic code
SET CLN=$$GET1^DIQ(9009083,+ECEIEN_",",5,"I")
+27 IF CLN]""
SET ECPIEN=$ORDER(^DIC(40.7,"C",CLN,""))
+28 ;
+29 ;Hospital Location
+30 SET HLI=$ORDER(^AMER(2.5,DUZ(2),8,"B",+ECEIEN,""))
IF HLI
Begin DoDot:2
+31 SET EHPIEN=$PIECE($GET(^AMER(2.5,DUZ(2),8,HLI,0)),U,2)
End DoDot:2
+32 ;If blank, pull original value
IF EHPIEN=""
SET EHPIEN=$GET(^AMER(2.5,DUZ(2),"SD"))
End DoDot:1
+33 ;
+34 ;Get PCC Clinic and Hospital Location
+35 SET PCIEN=$$GET1^DIQ(9000010,AMERPCC_",",.08,"I")
+36 SET PHIEN=$$GET1^DIQ(9000010,AMERPCC_",",.22,"I")
+37 ;
+38 ;If ER VISIT is blank or not equal to PCC copy from PCC
+39 IF PCIEN
IF (('ECEIEN)!(ECPIEN'=PCIEN))
Begin DoDot:1
+40 NEW AMERUPD,ERROR,ENCPIEN,CODE
+41 SET CODE=$$GET1^DIQ(40.7,PCIEN_",",1,"I")
IF 'CODE
QUIT
+42 SET ENCPIEN=$ORDER(^AMER(3,"B",CODE,""))
IF 'ENCPIEN
QUIT
+43 SET AMERUPD(9009080,AMERDA_",",.04)=ENCPIEN
+44 DO FILE^DIE("","AMERUPD","ERROR")
End DoDot:1
QUIT
+45 ;
+46 ;If PCC is blank copy from ER VISIT
+47 IF 'PCIEN
IF ECPIEN
Begin DoDot:1
+48 NEW AMERUPD,ERROR
+49 SET AMERUPD(9000010,AMERPCC_",",.08)=ECPIEN
+50 SET AMERUPD(9000010,AMERPCC_",",.22)=EHPIEN
+51 DO FILE^DIE("","AMERUPD","ERROR")
End DoDot:1
+52 ;
+53 QUIT
+54 ;
+55 ;GDIT/HS/BEE 07/12/2018;CR#10423 - AMER*3.0*10
GETCLN(AUPNVSIT) ;Return the ER Clinic for the PCC hospital location
+1 ;
+2 IF $GET(AUPNVSIT)=""
QUIT ""
+3 ;
+4 NEW HLOC,CLN,DIV
+5 ;
+6 SET DIV=$$GET1^DIQ(9000010,AUPNVSIT_",",".06","I")
IF DIV=""
SET DIV=$GET(DUZ(2))
IF DIV=""
QUIT ""
+7 ;
+8 SET CLN=""
+9 SET HLOC=$$GET1^DIQ(9000010,AUPNVSIT_",",.22,"I")
IF HLOC]""
Begin DoDot:1
+10 NEW CIEN
+11 SET CIEN=0
FOR
SET CIEN=$ORDER(^AMER(2.5,DIV,8,CIEN))
IF 'CIEN
QUIT
Begin DoDot:2
+12 NEW ECLN,EHLOC,DA,IENS
+13 SET DA(1)=DIV
SET DA=CIEN
SET IENS=$$IENS^DILF(.DA)
+14 SET EHLOC=$$GET1^DIQ(9009082.58,IENS_",",".02","I")
+15 IF HLOC'=EHLOC
QUIT
+16 SET ECLN=$$GET1^DIQ(9009082.58,IENS_",",".01","I")
IF ECLN=""
QUIT
+17 SET CLN=ECLN
End DoDot:2
IF CLN
QUIT
End DoDot:1
+18 ;
+19 ;If no clinic resort to pre-patch 10 logic
+20 IF CLN=""
Begin DoDot:1
+21 NEW CLINIC
+22 ;
+23 SET CLINIC=$$GET1^DIQ(9000010,AUPNVSIT_",",.08,"I")
+24 IF CLINIC]""
SET CLINIC=$$GET1^DIQ(40.7,CLINIC_",",1,"I")
+25 IF CLINIC]""
SET CLN=$ORDER(^AMER(3,"B",CLINIC,""))
End DoDot:1
+26 ;
+27 QUIT CLN
