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

AMER2A.m

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