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

AMEREDTD.m

Go to the documentation of this file. 
  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
  1.  ;
  1.  ;DISCHARGE
  1.  ;PROCEDURES
  1.  ;EXIT ASSESSMENT
  1.  ;FOLLOW UP INSTRUCTIONS 
  1.  ;
  1.  ; VARIABLES: The following variables are passed to multiple editing routines
  1.  ;  AMERDA  : the IEN of the ER VISIT that is selected for editing
  1.  ;  AMERAIEN: The IEN of the ER AUDIT that is created when user begins editing a record
  1.  ;  AMEREDNO: An integer representing the number of multiple fields that have been edited
  1.  ;            for uniqueness in multiple field number in audit file
  1.  ;            
  1.  ; Edit Auditing VARIABLES newed and used throughout edit routines:
  1.  ;      AMEROLD : original value of edited field
  1.  ;      AMERNEW : new value of edited field
  1.  ;      AMERSTRG : A ";" deliminated string of edit information for a field   
  1.  ;      
  1. EDDISCHG(AMERDA,AMERAIEN) ; EP from AMEREDIT for discharge information
  1.  ;QD17 - DISCHARGE PHYSICIAN
  1.  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
  1.  N AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DR,DIC,DIR
  1.  N AMERDR ;IHS/OIT/SCR 08/28/09 patch 2
  1.  S (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,AMERDR)=""
  1.  S DIC("A")="*(PRIMARY)Provider who signed PCC form: " K DIC("B"),DIC("S")
  1.  S DIC("?")="Only active providers can be selected"
  1.  I $P($G(^AMERVSIT(AMERDA,6)),U,4)'="" D
  1.  .S (AMEROLD,AMERNO)=$P($G(^AMERVSIT(AMERDA,6)),U,3)
  1.  .S DIC("B")=$P($G(^VA(200,AMERNO,0)),U)
  1.  .Q
  1.  S DIC="^VA(200,",DIC(0)="AEQ"
  1.  ;screening so that only valid PRIMARY providers are sent to PCC for Visit Creation
  1.  S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
  1.  D ^DIC
  1.  K DIC
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  I Y>0 D
  1.  .S AMERNEW=+Y
  1.  .I AMERNEW'=AMEROLD D
  1.  ..I AMERNEW="" S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.3////@"
  1.  ..I AMERNEW>0 S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.3////"_AMERNEW
  1.  ..S AMERSTRG=$$EDAUDIT^AMEREDAU("6.3",$$EDDISPL^AMEREDAU(AMEROLD,"N"),$$EDDISPL^AMEREDAU(AMERNEW,"N"),"DISCHARGE PROVIDER")
  1.  ..I AMERSTRG="^" Q
  1.  ..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ..Q
  1.  .Q
  1.  ;QD18 - DISCHARGE NURSE
  1.  S DIC("A")="Discharge nurse: ",AMERNO=""
  1.  K DIC("B")
  1.  S DIC("?")="Only active providers can be selected"
  1.  S (AMEROLD,AMERNO)=$P($G(^AMERVSIT(AMERDA,6)),U,4)
  1.  I AMEROLD'="" S DIC("B")=$P(^VA(200,AMERNO,0),U)
  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.  S DIC="^VA(200,",DIC(0)="AEQM"
  1.  D ^DIC K DIC
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  S AMERNEW=+Y
  1.  I AMERNEW'=AMEROLD D
  1.  .I AMERNEW>0 S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.4////"_AMERNEW
  1.  .S AMERSTRG=$$EDAUDIT^AMEREDAU("6.4",$$EDDISPL^AMEREDAU(AMEROLD,"N"),$$EDDISPL^AMEREDAU(AMERNEW,"N"),"DISCHARGE NURSE")
  1.  .I AMERSTRG="^" Q
  1.  .S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  .Q
  1.  ;QD19 - TIME OF DEPARTURE
  1.  S AMEROLD=$P($G(^AMERVSIT(AMERDA,6)),U,2)
  1.  I AMEROLD'="" S Y=$P($G(^AMERVSIT(AMERDA,6)),U,2) X ^DD("DD") S DIR("B")=Y
  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)"
  1.  F  Q:Y="^"  D
  1.  .D ^DIR
  1.  .I $D(DUOUT)!$D(DTOUT) S Y="^" Q
  1.  .S AMERNEW=Y
  1.  .;TVAL returns 0 if user says "yes they are sure they want this time..."
  1.  .I $$TVAL^AMER2A($P($G(^AMERVSIT(AMERDA,0)),U,1),AMERNEW,6) Q
  1.  .I AMERNEW="" S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.2////@"
  1.  .I $$TCK^AMER2A($P($G(^AMERVSIT(AMERDA,0)),U,1),AMERNEW,1,"admission")=0  D
  1.  ..I AMERNEW=AMEROLD S Y="^" Q
  1.  ..S AMERSTRG=$$EDAUDIT^AMEREDAU("6.2",$$EDDISPL^AMEREDAU(AMEROLD,"D"),$$EDDISPL^AMEREDAU(AMERNEW,"D"),"DEPARTURE TIME")
  1.  ..I AMERSTRG="^" Q
  1.  ..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ..S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.2///"_AMERNEW
  1.  ..S Y="^"
  1.  ..Q
  1.  .Q
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  IF AMERDR'="" D
  1.  .D DIE^AMEREDIT(AMERDA,AMERDR)
  1.  .Q
  1.  D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
  1.  K AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DIC,DIR,AMERDR
  1.  Q 1
  1.  ;
  1. EDPROCS(AMERDA,AMEREDNO,AMERAIEN) ;  EP from AMEREDIT - ER PROCEDURES  
  1.  N AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG
  1.  S (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,Y)=""
  1.  S AMERNO=0
  1.  K DIC("B"),DIC("S")
  1.  I $P($G(^AMERVSIT(AMERDA,4,0)),U,3)="" D EN^DDIOL("No procedure(s) have been entered:","","!")
  1.  E  D
  1.  .D EN^DDIOL("The following procedure(s) have been entered: ","","!")
  1.  .D EN^DDIOL("","","!")
  1.  .S AMERNO=0
  1.  .F  S AMERNO=$O(^AMERVSIT(AMERDA,4,AMERNO)) Q:AMERNO="B"  D
  1.  ..S Y=$G(^AMERVSIT(AMERDA,4,AMERNO,0)),Y1=$G(^AMER(3,Y,0))
  1.  ..D EN^DDIOL($P(Y1,U,1),"","!")
  1.  ..Q
  1.  .Q
  1.  D EN^DDIOL("","","!")
  1.  F  Q:Y="^"  D
  1.  .S SKIP=0
  1.  .S DIC="^AMER(3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=20",Y=""  ;only show type 20 -ER PROCEDURES
  1.  .S DIC("A")="Enter "_$S($P($G(^AMERVSIT(AMERDA,4,0)),U,3)>0:"another ",1:"a ")_"procedure: "
  1.  .D ^DIC
  1.  .I $G(Y)<=0 S Y="^" Q
  1.  .;First look to see if that procedure has already been entered
  1.  .;if it has, we give the user a chance to delete it
  1.  .S AMERNO=0
  1.  .F  S AMERNO=$O(^AMERVSIT(AMERDA,4,AMERNO)) Q:'AMERNO  I ^AMERVSIT(AMERDA,4,AMERNO,0)=$P(Y,U,1) D
  1.  ..S SKIP=1
  1.  ..S AMEROLD=$G(^AMERVSIT(AMERDA,4,AMERNO,0))
  1.  ..S DIR(0)="Y",DIR("A")="Delete this procedure? ",DIR("B")="NO"
  1.  ..D ^DIR
  1.  ..I Y=1  D
  1.  ...S AMEREDNO=AMEREDNO+1
  1.  ...S AMERNEW=""
  1.  ...S AMERSTRG=$$EDAUDIT^AMEREDAU("4-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMEROLD,"R"),$$EDDISPL^AMEREDAU(AMERNEW,"R"),"PROCEDURE")
  1.  ...I AMERSTRG="^" Q
  1.  ...S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ...S DA(1)=AMERDA,DA=AMERNO,DIK="^AMERVSIT(DA(1),4,"
  1.  ...D ^DIK,EN^DIK K DIK  ;Kill the record and Re-index 
  1.  ...Q
  1.  ..S (AMERNO,Y)=""
  1.  ..Q
  1.  .I 'SKIP D
  1.  ..S DA(1)=AMERDA,DIC="^AMERVSIT(DA(1),4,",DIC(0)="L",DIC("P")=$P(^DD(9009080,4,0),U,2) ; PROCEDURES
  1.  ..S AMEROLD="",AMERNEW=+Y
  1.  ..S X="`"_+Y
  1.  ..D ^DIC K DIC  ;add a new entry
  1.  ..S AMERNO=+Y,AMEREDNO=AMEREDNO+1
  1.  ..S AMERSTRG=$$EDAUDIT^AMEREDAU("4-1"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMEROLD,"R"),$$EDDISPL^AMEREDAU(AMERNEW,"R"),"PROCEDURE")
  1.  ..I AMERSTRG="^" Q
  1.  ..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ..Q
  1.  .Q
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT  Q 0
  1.  D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
  1.  K AMERNO,Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG
  1.  Q 1
  1.  ;
  1. EDEXTAS(AMERDA,AMERAIEN)   ;EP from AMEREDIT - ER EXIT ASSESSMENT 
  1.  ;QD12 - FINAL TRIAGE CATEGORY
  1.  N Y,AMEROLD,AMERNEW,AMEREDTS,AMERDR,AMERSTRG,AMEROPTN,AMERFAC,AMERM,DIR,DIC,AMEROPNO
  1.  S (AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,AMERDR,Y)=""
  1.  S AMEROLD=$P($G(^AMERVSIT(AMERDA,5.1)),U,4)
  1.  I AMEROLD'="" S DIR("B")=AMEROLD
  1.  S DIR(0)="NO^1:5:0",DIR("A")="Enter final acuity assessment from provider"
  1.  S DIR("?")="Enter a number from 1 to 5 - This is a required field"
  1.  F  Q:Y="^"  D
  1.  .D ^DIR
  1.  .I $D(DUOUT)!$D(DTOUT) S Y="^" Q
  1.  .S AMERNEW=Y
  1.  .I AMERNEW=AMEROLD S Y="^" Q
  1.  .I AMERNEW>0 D
  1.  ..S AMERSTRG=$$EDAUDIT^AMEREDAU("4.1",AMEROLD,AMERNEW,"FINAL ACUITY")
  1.  ..I AMERSTRG="^" Q
  1.  ..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ..S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"5.4///"_Y
  1.  ..S Y="^"
  1.  ..Q
  1.  .Q
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  I AMERDR'="" D
  1.  .D DIE^AMEREDIT(AMERDA,AMERDR)
  1.  .Q
  1.  D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
  1.  S (DR,AMEREDTS)=""
  1.  ;QD14 - DISPOSITION and transfer
  1.  S AMEROPNO=""
  1.  I $P($G(^AMERVSIT(AMERDA,6)),U,1)'="" S (AMEROLD,AMEROPNO)=$P($G(^AMERVSIT(AMERDA,6)),U,1)
  1.  S DIC("A")="Disposition: " K DIC("B"),DIC("S")
  1.  S DIC="^AMER(3,",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("DISPOSITION")
  1.  I AMEROPNO'="" S DIC("B")=$P($G(^AMER(3,AMEROPNO,0)),U,1)
  1.  D ^DIC K DIC
  1.  I AMEROLD=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION") D
  1.  .D EN^DDIOL("This disposition can not be changed!!","","!")
  1.  .S AMERNEW=AMEROLD
  1.  E  S AMERNEW=+Y
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  ;IHS/OIT/SCR - 10/08/08 - START if the new value is Registered in error delete PCC VISIT
  1.  I (AMERNEW>0) D
  1.  .I AMERNEW=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION") D
  1.  ..D EN^DDIOL("This DISPOSITION will cause this entire VISIT to be deleted!!","","!")
  1.  ..S DIR(0)="Y",DIR("A")="Do you still wish to keep this DISPOSITION"
  1.  ..S DIR("B")="YES"
  1.  ..D ^DIR
  1.  ..I Y=0 S AMERNEW=AMEROLD
  1.  ..I Y=1 D
  1.  ...D DELETVST^AMERVSIT(AMERDA)
  1.  ...S AMERDA=0
  1.  ...Q
  1.  ..Q  ;IHS/OIT/SCR - 10/08/08 - END if the new value is Registered in error delete PCC VISIT
  1.  .S AMEROPTN=$$OPT^AMER0("TRANSFER","DISPOSITION")
  1.  .I (AMERNEW'=AMEROLD) D
  1.  ..S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.1///"_AMERNEW
  1.  ..S AMERSTRG=$$EDAUDIT^AMEREDAU("6.1",$$EDDISPL^AMEREDAU(AMEROLD,"I"),$$EDDISPL^AMEREDAU(AMERNEW,"I"),"DISPOSITION")
  1.  ..I AMERSTRG="^" Q
  1.  ..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ..;If the old value was "transfer to another facility, delete facility associated
  1.  ..I AMEROLD=AMEROPTN D  S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.6////@"
  1.  ..Q
  1.  .I AMERNEW=AMEROPTN D
  1.  ..;IF the new value is "transfer to another facility", collect facility information
  1.  ..D EN^DDIOL("","","!")
  1.  ..S AMEROLD=""
  1.  ..I $P($G(^AMER(2.1,0)),U,3)="" D EN^DDIOL("No local ER Facilities found","","!") Q
  1.  ..S DIC="^AMER(2.1,",DIC(0)="AEQM"
  1.  ..S DIC("A")="Where is patient being transferred? "
  1.  ..S AMERFAC=$P($G(^AMERVSIT(AMERDA,6)),U,6)
  1.  ..I AMERFAC'="" S (DIC("B"),AMEROLD)=$P($G(^AMER(2.1,AMERFAC,0)),U,1)
  1.  ..E  S AMERM=$O(^AMER(2.1,0))
  1.  ..D ^DIC K DIC
  1.  ..I +Y>0 S AMERNEW=$P($G(^AMER(2.1,+Y,0)),U,1)
  1.  ..E  S AMERNEW=""
  1.  ..I +Y>0&(AMERNEW'=AMEROLD) D
  1.  ...S AMERDR=$S(AMERDR'="":AMERDR_";",1:""),AMERDR=AMERDR_"6.6////"_+Y
  1.  ...S AMERSTRG=$$EDAUDIT^AMEREDAU("6.6",AMEROLD,AMERNEW,"TRANSFER TO")
  1.  ...I AMERSTRG="^" Q
  1.  ...S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
  1.  ...Q
  1.  ..Q
  1.  ..E  I AMEROPTN<0 D
  1.  ...D EN^DDIOL("Option 'TRANSFER TO ANOTHER FACILITY' is missing ","","!")
  1.  ...D EN^DDIOL("This DISPOSITION type is required for collection of transfer location ","","!")
  1.  ...Q
  1.  ..Q
  1.  .I AMEROLD=AMEROPTN
  1.  .Q  ;IF NEW>0
  1.  I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  IF AMERDR'="" D
  1.  .D DIE^AMEREDIT(AMERDA,AMERDR)
  1.  .Q
  1.  D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
  1.  K Y,AMEROLD,AMERNEW,AMEREDTS,AMERSTRG,DR,AMERDR,AMEROPTN,AMERFAC,AMERM,DIR,DIC
  1.  Q 1
  1.  ;
  1. EDFUINST(AMERDA,AMERAIEN) ;EP - From AMEREDIT
  1.  ;QD16 - DISCHARGE INSTRUCTIONS
  1.  NEW FIIEN,CNT,FI,DIR,%,AMEROLD
  1.  ;
  1.  ;Get the default entry
  1.  S AMEROLD=$$GET1^DIQ(9009080,AMERDA_",",7,"I") S:AMEROLD]"" DIR("B")=$$GET1^DIQ(9009083,AMEROLD_",",.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.  . 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.  ;
  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 $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0
  1.  S AMERNEW=$S(+Y>0:+Y,1:"")
  1.  ;
  1.  ;Save/Audit
  1.  I AMERNEW'=AMEROLD D
  1.  . NEW AMERSTRG,DR
  1.  . S AMERSTRG=$$EDAUDIT^AMEREDAU("7",$$EDDISPL^AMEREDAU(AMEROLD,"F"),$$EDDISPL^AMEREDAU(AMERNEW,"F"),"DISCHARGE INSTRUCTIONS")
  1.  . S DR="7////"_$S(AMERNEW]"":AMERNEW,1:"@")
  1.  . D DIE^AMEREDIT(AMERDA,DR)
  1.  . I AMERSTRG="^" Q
  1.  . D DIEREC^AMEREDAU(AMERAIEN,AMERSTRG)
  1.  ;
  1.  Q 1