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

AMER3.m

Go to the documentation of this file. 
  1. AMER3 ; IHS/ANMC/GIS - MORE DISCHARGE QUESTIONS ;  
  1.  ;;3.0;ER VISIT SYSTEM;**6**;MAR 03, 2009;Build 30
  1.  ;
  1. QD10 ; ER PROCEDURES
  1.  N AMERNONE S AMERNONE=$$OPT^AMER0("NONE","ER PROCEDURES")
  1.  ; W "Type '??' to see choices"
  1.  S AMEROPT=""
  1.  I $D(^TMP("AMER",$J,2,10,AMERNONE))!('$D(^TMP("AMER",$J,2,10))) S DIC("B")="NONE" G DIC
  1.  D PREV(10)
  1. DIC S DIC("A")="Enter "_$S($O(^TMP("AMER",$J,2,10,0)):"another ",1:"")_"procedure: "
  1.  S DIC="^AMER(3,",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("ER PROCEDURES")
  1.  D ^DIC K DIC
  1.  I $P(Y,U,2)="NONE" K ^TMP("AMER",$J,2,10) S ^TMP("AMER",$J,2,10,AMERNONE)=Y Q
  1.  I X?2."^" S DIROUT=""
  1.  D OUT^AMER I $D(AMERQUIT) Q
  1.  I "^"[$E(X) S Y="" Q
  1.  I $D(^TMP("AMER",$J,2,10,+Y)) D REM(10,Y) Q:$D(AMERQUIT)  G DIC
  1.  S ^TMP("AMER",$J,2,10,+Y)=Y I +Y'=AMERNONE K ^(AMERNONE)
  1.  G DIC
  1.  ;
  1. REM(X,Y) W !,*7,$P(Y,U,2)," has already been selected. Want to cancel it"
  1.  S %=2 D YN^DICN S:%Y?2."^" DIROUT="" D OUT^AMER I $D(AMERQUIT) Q
  1.  I "Nn"[$E(%Y) Q
  1.  K ^TMP("AMER",$J,2,X,+Y) W !,$P(Y,U,2)," cancelled...",!!
  1.  Q
  1.  ;
  1. PREV(X) ; ENTRY POINT FROM AMER31
  1.  W !,"You have already selected =>",!
  1.  F %=0:0 S %=$O(^TMP("AMER",$J,2,X,%)) Q:'%  W ?3,$P(^(%),U,2),!
  1.  W !
  1.  Q
  1.  ;
  1. QD11 ; FINAL DIAGNOSES
  1.  D QD11^AMER31
  1.  Q
  1.  ;
  1. QD12 ; FINAL TRIAGE CATEGORY
  1.  S DIR("B")=$G(^TMP("AMER",$J,2,12))
  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 final acuity assessment from provider" KILL DA D ^DIR KILL DIR
  1.  D OUT^AMER
  1.  Q
  1.  ;
  1. QD14 ; DISPOSITION AND SCHEDULING
  1.  N AMERDISP   ;IHS/OIT/SCR 10/10/08
  1.  S DIC("A")="*Disposition: " K DIC("B")
  1.  I $G(^TMP("AMER",$J,2,14))>0 S %=+^(14),DIC("B")=$P(^AMER(3,%,0),U)
  1.  ;I $D(^TMP("AMER",$J,2,14)) S %=+^(14),DIC("B")=$P(^AMER(3,%,0),U) ;IHS/OIT/SCR 10/10/08
  1.  I $D(AMERDOA) S DIC("B")="DEATH"
  1.  I $D(AMERDNA) D
  1.  .;IHS/OIT/SCR 01/20/09 - OPTION  MAY BE 'LEFT WITHOUT BEING SEEN' OR 'LEFT WITHOUT BEING DISCHARGED'
  1.  .S DIC="^AMER(3,",DIC(0)="",X="LEFT WITHOUT"
  1.  .D ^DIC
  1.  .I Y>0 S DIC("B")=$P(Y,"^",2)
  1.  .E  S DIC("B")=""
  1.  .Q
  1.  S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("DISPOSITION"),DIC(0)="AEQ"
  1.  D ^DIC K DIC D OUT^AMER I $D(AMERQUIT) Q
  1.  I Y=-1 Q
  1.  S AMERDISP=+Y
  1.  I AMERDISP=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION") D  Q
  1.  .D EN^DDIOL("Using this DISPOSITION will cause the entire VISIT to be deleted!!","","!")
  1.  .D EN^DDIOL("This DISPOSITION can not be changed!!","","!")
  1.  .S DIR(0)="Y",DIR("A")="Do you still wish use this DISPOSITION"
  1.  .S DIR("B")="YES"
  1.  .D ^DIR
  1.  .I Y=0 D
  1.  ..S AMERRUN=13
  1.  ..S ^TMP("AMER",$J,2,14)=""
  1.  ..Q
  1.  .I Y=1 S AMERRUN=95
  1.  .Q
  1.  Q:AMERRUN=95
  1.  ;I +Y=$$OPT^AMER0("HOME","DISPOSITION") S AMERRUN=15 D SCHEDULE Q
  1.  I AMERDISP'=$$OPT^AMER0("TRANSFER TO ANOTHER FACILITY","DISPOSITION") S AMERRUN=15
  1.  I AMERDISP'=$$OPT^AMER0($P($G(^AMER(3,AMERDISP,0)),U),"DISPOSITION") K ^TMP("AMER",$J,2,15)
  1.  S Y=AMERDISP
  1.  Q
  1.  ;
  1. QD15 ; OTHER FACILITIES
  1.  ;W "If location lookup fails, try entering 'OTHER'"  - IHS/OIT/SCR 10/09/08 commented out
  1.  S DIR("A")="Where is patient being transferred" K DIR("B")
  1.  I $D(^TMP("AMER",$J,2,15)) S %=+^(15),DIR("B")=$P(^AMER(2.1,%,0),U)
  1.  ;S DIR(0)="P^9009082.1:EMZ" D ^DIR K DIR
  1.  S DIR(0)="PO^9009082.1:OEMZ" D ^DIR K DIR  ;SCR/CNI/OIT - MAKE RESPONSE OPTIONAL
  1.  D OUT^AMER
  1.  Q
  1.  ;
  1. QD16 ; DISCHARGE INSTRUCTIONS
  1.  NEW FIIEN,CNT,FI,DIR,%,INS
  1.  ;
  1.  ;Get the default entry
  1.  I $G(^TMP("AMER",$J,2,16))]"" S %=+^(16) S:%]"" DIR("B")=$$GET1^DIQ(9009083,%_",",.01,"I")
  1.  ;
  1.  S CNT=0
  1.  S DIR(0)="SO^"
  1.  S FIIEN=$O(^AMER(2,"B","FOLLOW UP INSTRUCTIONS",""))
  1.  S FI="" F  S FI=$O(^AMER(3,"AC",FIIEN,FI)) Q:FI=""  D
  1.  . NEW INSNM
  1.  . S CNT=CNT+1
  1.  . S INSNM=$$GET1^DIQ(9009083,FI_",",".01","I") Q:INSNM=""
  1.  . S INS(CNT)=INSNM_U_FI
  1.  . S DIR(0)=DIR(0)_$S(CNT>1:";",1:"")_CNT_":"_INSNM
  1.  . I INSNM="RTC PRN, INSTRUCTIONS GIVEN",'$D(DIR("B")) S DIR("B")=INSNM
  1.  ;
  1.  S DIR("A")="Follow up instructions"
  1.  D ^DIR
  1.  ;
  1.  ;Process invalid entries
  1.  I +Y<1,X'="@" S X="^",Y="^" D OUT^AMER Q
  1.  ;
  1.  ;Handle proper selection
  1.  I +Y>0 S Y=$P(INS(+Y),U,2)
  1.  ;
  1.  I X="@" S X="",Y=""
  1.  D OUT^AMER
  1.  Q
  1.  ;
  1. QD17 ; DISCHARGE PHYSICIAN
  1.  S DIC("A")="*(PRIMARY)Provider who signed PCC form: " K DIC("B")
  1.  I '$D(^TMP("AMER",$J,2,17)) S %=$G(^TMP("AMER",$J,2,21)) I %]"" S ^TMP("AMER",$J,2,17)=%
  1.  I $D(^TMP("AMER",$J,2,17)) S %=+^(17),DIC("B")=$P(^VA(200,%,0),U)
  1.  S DIC="^VA(200,",DIC(0)="AEMQ"
  1.  ; Screening so that only valid PCC providers identified
  1.  S DIC("?")="Only active providers can be selected"
  1.  S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
  1.  D ^DIC K DIC
  1.  D OUT^AMER
  1.  Q
  1.  ;
  1. QD18 ; DISCHARGE NURSE
  1.  S DIC("A")="*Discharge nurse: " K DIC("B")
  1.  I $D(^TMP("AMER",$J,2,18)) S %=+^(18),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("?")="Only active providers can be selected"
  1.  S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
  1.  D ^DIC K DIC
  1.  D OUT^AMER
  1.  I $D(AMERDOA) D
  1.  .S %=$$OPT^AMER0("NONE","ER PROCEDURES"),^TMP("AMER",$J,2,10,%)=%_U_"NONE"
  1.  .S ^TMP("AMER",$J,1,6)=^TMP("AMER",$J,2,17)
  1.  .S ^TMP("AMER",$J,1,7)=Y
  1.  .S ^TMP("AMER",$J,2,12)=$G(^TMP("AMER",$J,1,9))
  1.  .S %=$$OPT^AMER0("DEATH","DISPOSITION"),^TMP("AMER",$J,2,14)=%_"^DEATH"
  1.  .Q
  1.  Q
  1.  ;
  1. QD19 ; TIME OF DEPARTURE
  1.  I $D(^TMP("AMER",$J,2,19)) S Y=^(19) X ^DD("DD") S DIR("B")=Y
  1.  I '$T S DIR("B")="NOW"
  1.  ;IHS/OIT/SCR 10/10/08 - Mark question mandatory
  1.  ;S DIR(0)="DO^::ER",DIR("A")="What time did the patient depart from the ER",DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)" D ^DIR K DIR
  1.  S DIR(0)="DO^::ER",DIR("A")="*What time did the patient depart from the ER"
  1.  S DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)" D ^DIR K DIR
  1.  I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,1,2)),Y,1,"admission") K Y G QD19
  1.  I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,2,24)),Y,1,"triage") K Y G QD19
  1.  I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,2,25)),Y,1,"the provider visit") K Y G QD19
  1.  I Y,$$TVAL^AMER2A($G(^TMP("AMER",$J,1,2)),Y,6) K Y G QD19
  1.  I Y="" S Y=-1
  1.  D OUT^AMER
  1.  S AMERRUN=99
  1.  Q
  1.  ;
  1. SCHEDULE ; APPOINTMENT STUB
  1.  Q