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

BDGAPI2.m

Go to the documentation of this file. 
  1. BDGAPI2 ; IHS/ANMC/LJF - PATIENT MOVEMENT API'S ;  [ 09/26/2002  12:56 PM ]
  1.  ;;5.3;PIMS;**1010**;APR 26, 2002
  1.  ;
  1.  ;cmi/flag/maw 08/31/2009 PATCH 1010 changed references of UB92 to UB04
  1.  ;
  1.  ; See BDGAPI for full details on variables
  1.  ;
  1. EDIT(BDGR) ;EP; silent API to edit patient movement entries to file 405
  1.  NEW DGQUIET,BDGAPI,ERR,BDGCA,BDGN,BDGTRAN,VST,BDGV,BDGMVT,X
  1.  S DGQUIET=1              ;must be in quiet mode
  1.  S BDGAPI=1               ;let DGPMV rtns know using API
  1.  ;
  1.  S ERR=$$CHECK(.BDGR) I ERR Q ERR   ;check common req fields
  1.  ;
  1.  D FINDADM   ;find admission to edit
  1.  ;
  1.  ; if none found, try to add admission
  1.  I ('BDGV),('BDGCA) S BDGR("TRAN")=1 Q $$ADD^BDGAPI(.BDGR)
  1.  ;
  1.  I '$G(BDGCA) Q 2_U_"Cannot find 405 entry for visit ien "_BDGV
  1.  ;
  1.  ; if no acct # on visit, add it now
  1.  I BDGV,$$GET1^DIQ(9000010,BDGV,1211)="" D
  1.  . S DA=BDGV,DIE="^AUPNVSIT(",DR="1211///"_BDGR("ACCT") D ^DIE
  1.  ;
  1.  ;
  1.  ; now look for what was changed
  1.  S BDGTRAN=""             ;will be reset to transaction if edit found
  1.  ;
  1.  ; if discharge date sent, assume editing discharge
  1.  I BDGR("DISCHARGE DATE")]"" D  Q ERR
  1.  . NEW BDGN S BDGN=$$GET1^DIQ(405,BDGCA,.17,"I")   ;discharge ien
  1.  . ;  if not discharged yet, add one
  1.  . I 'BDGN S BDGR("TRAN")=3 S ERR=$$ADD^BDGAPI(.BDGR) Q
  1.  . ;  otherwise look for changes to discharge
  1.  . I BDGR("DISCHARGE DATE")'=+$G(^DGPM(BDGN,0)) S BDGTRAN=3
  1.  . ;8/26/2002 WAR per LJF27
  1.  . ;I BDGR("DSCT")'=$$GET1^DIQ(405.1,+$$GET1^DIQ(405,BDGN,.04,"I"),9999999.1) S BDGTRAN=3
  1.  . I BDGR("DSCT")'=$$GET1^DIQ(405,BDGN,.04,"I") S BDGTRAN=3  ;IHS/ANMC/LJF 9/12/2002 pointer sent, not ihs code
  1.  . I BDGTRAN=3 D @BDGTRAN
  1.  ;
  1.  ; check admission data for changes
  1.  NEW BDGRM S BDGRM=BDGR("ROOM")   ;save orignal room value
  1.  I BDGR("ADMIT DATE")'=+^DGPM(BDGCA,0) S BDGTRAN=1
  1.  I BDGR("UBAS")]"",BDGR("UBAS")'=$$GET1^DIQ(9999999.53,+$$GET1^DIQ(405,BDGCA,9999999.06,"I"),.02) S BDGTRAN=1
  1.  I BDGR("UBAT")]"",BDGR("UBAT")'=$$GET1^DIQ(405,BDGCA,9999999.05,"I") S BDGTRAN=1
  1.  I BDGR("TFAC")]"",BDGR("TFAC")'=$$GET1^DIQ(405,BDGCA,.05) S BDGTRAN=1
  1.  I BDGR("ADMD")'=$$GET1^DIQ(405,+$$ADMTXN^BDGF1(BDGCA,BDGR("PAT")),9999999.02) S BDGTRAN=1
  1.  I BDGTRAN=1 D @BDGTRAN Q ERR
  1.  ;
  1.  ; check last movement for ward or room changes
  1.  S BDGTRAN=""
  1.  S BDGN=$$PRIORMVT^BDGF1(BDGR("DATE"),BDGCA,BDGR("PAT"))
  1.  S BDGMVT=$S(BDGN=BDGCA:1,1:2)  ;is movement admit or transfer
  1.  I 'BDGN Q 2_U_"Cannot find last movement before event date; DATE="_BDGR("DATE")
  1.  I BDGR("WARD")'=$$GET1^DIQ(405,BDGN,.06) S BDGTRAN=BDGMVT
  1.  I BDGTRAN]"" D @BDGTRAN I ERR Q ERR
  1.  ;
  1.  ; check last service transfer for changes
  1.  S BDGTRAN=""
  1.  S BDGN=$$PRIORTXN^BDGF1(BDGR("DATE"),BDGCA,BDGR("PAT"))
  1.  I 'BDGN Q 2_U_"Cannot find last service transfer for event date: "_BDGR("DATE")
  1.  I BDGR("ATMD")'=$$GET1^DIQ(405,BDGN,.19) S BDGTRAN=6
  1.  I BDGR("SRV")'=$$GET1^DIQ(45.7,+$$GET1^DIQ(405,BDGN,.09,"I"),9999999.01) S BDGTRAN=6
  1.  I BDGTRAN=6,BDGR("DATE")=BDGR("ADMIT DATE") D 1 Q ERR
  1.  I BDGTRAN=6 S BDGR("TRAN")=6 Q $$ADD^BDGAPI(.BDGR)
  1.  ;
  1.  I BDGR("ROOM")'=$G(^DPT(BDGR("PAT"),.101)) S DGPMCA=BDGCA,DFN=BDGR("PAT") D BED^BDGAPI
  1.  ;
  1.  Q $G(ERR)
  1.  ;
  1.  ;
  1. 1 ; edit admission
  1.  NEW DGPMT,DGPMP,DFN,I,DGPMY,DGPMCA,DGPMSA,DGPMUC,DGPMN,BDGN,X
  1.  S DGPMT=1,DFN=BDGR("PAT"),ERR="",DGPMN=0
  1.  ;
  1.  ; check admission fields for validity
  1.  F I="WARD","SRV","ADMT","ADX","ADMD","ATMD" D @I I +ERR=2 Q
  1.  I +ERR=2 Q   ;at least one required field failed check
  1.  ;
  1.  ; if enough fields are okay, edit admission
  1.  S BDGR("DATE")=BDGR("ADMIT DATE")   ;"date" used by serv transfer
  1.  S DGPMY=BDGR("ADMIT DATE"),(DGPMCA,DGPMDA,DA)=BDGCA,DGPMSA=0,DGPMOUT=0
  1.  S DGPMP=$G(^DGPM(DGPMDA,0))        ;prior state of data
  1.  D UC^DGPMV  ; sets DGPMUC = transaction type external format
  1.  D VAR^DGPMV3,DR^DGPMV3
  1.  Q
  1.  ;
  1. 2 ; edit transfer
  1.  NEW DGPMT,DGPMP,DFN,I,DGPMY,DGPMCA,DGPMSA,DGPMUC,DGPMN,DGPMAN
  1.  S DGPMT=2,DGPMP="",DFN=BDGR("PAT"),ERR=""
  1.  S DGPMN=1   ;prevents date from being asked
  1.  S DGPMDA=BDGN,DGPMCA=BDGCA
  1.  ;
  1.  ;
  1.  ; check transfer fields for validity
  1.  F I="WARD" D @I I +ERR=2 Q
  1.  I +ERR=2 Q   ;at least one required field failed check
  1.  ;
  1.  ; if enough fields are okay, edit event
  1.  S DGPMY=BDGR("DATE"),DGPMAN=$G(^DGPM(DGPMCA,0))
  1.  D UC^DGPMV  ; sets DGPMUC = transaction type external format
  1.  D VAR^DGPMV3,DR^DGPMV3
  1.  Q
  1.  ;
  1. 3 ; add discharge
  1.  NEW DGPMT,DGPMP,DFN,I,DGPMY,DGPMCA,DGPMSA,DGPMUC,DGPMN,DGPMAN
  1.  S DGPMT=3,DGPMP="",DFN=BDGR("PAT"),ERR=""
  1.  S DGPMN=1   ;prevents date from being asked
  1.  S DGPMDA=BDGN,DGPMCA=BDGCA
  1.  ;
  1.  ;
  1.  ; check discharge fields for validity
  1.  F I="DSCT" D @I I +ERR=2 Q
  1.  I +ERR=2 Q   ;at least one required field failed check
  1.  ;
  1.  ; if enough fields are okay, create event
  1.  S DGPMY=BDGR("DISCHARGE DATE"),DGPMAN=$G(^DGPM(DGPMCA,0))
  1.  ;
  1.  ;6/19/2002 LJF9 (per Linda) change errors to warnings -next line was
  1.  ;   already changed via LJF6
  1.  I DGPMY<$P(DGPMAN,U) S ERR=2_U_"Discharge Date BEFORE Admission Date; Cannot Edit" Q  ;IHS/ANMC/LJF 5/31/2002 (per LJF6)
  1.  ;
  1.  D UC^DGPMV  ; sets DGPMUC = transaction type external format
  1.  D VAR^DGPMV3,DR^DGPMV3
  1.  Q
  1.  ;
  1. 6 ; add treating specialty transfer
  1.  NEW DGPMT,DGPMP,DFN,I,DGPMY,DGPMCA,DGPMSA,DGPMUC,DGPMN,DGPMAN
  1.  S DGPMT=6,DGPMP="",DFN=BDGR("PAT"),ERR=""
  1.  S DGPMN=1   ;prevents date from being asked
  1.  S DGPMDA=BDGN,DGPMCA=BDGCA
  1.  ;
  1.  ; check service transfer fields for validity
  1.  F I="SRV","ATMD" D @I I +ERR=2 Q
  1.  I +ERR=2 Q   ;at least one required field failed check
  1.  ;
  1.  ; if transfer being edited is 1st one, use admit date for date
  1.  I $P(^DGPM(DGPMDA,0),U,24)=DGPMCA S BDGR("DATE")=BDGR("ADMIT DATE")
  1.  ;
  1.  ; if enough fields are okay, create event
  1.  S DGPMY=BDGR("DATE"),DGPMAN=$G(^DGPM(DGPMDA,0))
  1.  D UC^DGPMV  ; sets DGPMUC = transaction type external format
  1.  D VAR^DGPMV3,DR^DGPMV3
  1.  Q
  1.  ;
  1.  ;
  1. WARD ; -- check ward and room-bed
  1.  NEW X,DIC,Y
  1.  ; check required ward
  1.  S X=$G(BDGR("WARD")),DIC=42,DIC(0)="M"
  1.  S DIC("S")="I $P($G(^BDGWD(+Y,0)),U,3)=""A""" D ^DIC
  1.  I Y=-1 S ERR=2_U_"Ward error: "_BDGR("WARD") Q
  1.  ;
  1.  ; check optional room-bed
  1.  S X=$G(BDGR("ROOM")) I X]""  D
  1.  . K DIC S DIC=405.4,DIC(0)="M" D ^DIC
  1.  . I Y<1 S ERR=ERR_1_U_"Invalid room-"_BDGR("ROOM")_U,BDGR("ROOM")="" Q
  1.  . I $D(^DPT("RM",BDGR("ROOM"))),'$D(^DPT("RM",BDGR("ROOM"),DFN)) S ERR=ERR_1_U_"Room-bed already occupied: "_BDGR("ROOM")_U,BDGR("ROOM")=""
  1.  Q
  1.  ;
  1. SRV ; -- check service (screen for active admitting services)
  1.  NEW X,DIC,Y
  1.  ; check if observation event has observation type service
  1.  I $G(BDGR("MINOR TYPE"))="V",BDGR("SRV")'["O" S BDGR("SRV")=BDGR("SRV")_"O"
  1.  ;
  1.  S X=$G(BDGR("SRV")),DIC=45.7,DIC(0)="M"
  1.  S DIC("S")="I $$ACTIVE^DGACT(45.7,+Y,BDGR(""DATE""))" D ^DIC
  1.  I Y<1 S ERR=2_U_"Invalid Service: "_BDGR("SRV")
  1.  Q
  1.  ;
  1. ADMT ; -- check admit types/source
  1.  NEW X,DIC,Y
  1.  Q:BDGR("UBAS")=""   ;if not sent with edit, don't check
  1.  D ADMT^BDGAPI
  1.  Q
  1.  ;
  1. DSCT ; -- check discharge types
  1.  NEW X,DIC,Y
  1.  ; check required IHS discharge type
  1.  S X=$G(BDGR("DSCT")),DIC=405.1,DIC(0)="M"
  1.  S DIC("S")="I $P(^DG(405.1,+Y,0),U,2)=3" D ^DIC
  1.  I Y<1 S ERR=2_U_"IHS Discharge Type Invalid: "_BDGR("DSCT") Q
  1.  ;
  1.  I (BDGR("DSCT")=13) D  Q:+ERR=2
  1.  . S X=$G(BDGR("TFAC")) I X="" S ERR=2_U_"Transfer Facility Missing" Q
  1.  . K DIC S DIC=9999999.91,DIC(0)="M"
  1.  . S DIC("S")="I $P(^AUTTTFAC(+Y,0),U,2)=""""" D ^DIC
  1.  . I Y<1 S ERR=2_U_"Invalid Transfer Facility: "_BDGR("TFAC")
  1.  ;
  1.  ; check optional ub04 discharge status
  1.  S X=$G(BDGR("UBDS")) I X]"" D
  1.  . I "^1^2^3^4^5^6^7^10^20^30"'[X S ERR=ERR_1_U_"Invalid UB04 Discharge Status: "_$G(BDGR("UBDS"))_U,BDGR("UBDS")=""  ;cmi/maw 08/31/2009 PATCH 1010
  1.  Q
  1.  ;
  1. ADX ; check admitting dx
  1.  NEW X
  1.  S X=$G(BDGR("ADX")) I X="" Q
  1.  I $L(X)<3 S ERR=2_U_"Admitting dx too short: "_X Q
  1.  I $L(X)>30 S ERR=2_U_"Admitting dx too long: "_X Q
  1.  Q
  1.  ;
  1. ADMD ; check admitting and referring provider fields
  1.  NEW X,DIC,Y
  1.  ; check required admitting physician
  1.  Q:BDGR("ADMD")=""   ;if not sent with edit, don't check
  1.  S X=$G(BDGR("ADMD")) I X="" S ERR=2_U_"Admitting Provider Missing" Q
  1.  S DIC=200,DIC(0)="M"
  1.  S DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
  1.  D ^DIC I Y<1 S ERR=2_U_"Invalid Admitting Provider: "_BDGR("ADMD") Q
  1.  ;
  1.  ; check optional referring provider
  1.  S X=$G(BGR("REFP")) Q:X=""
  1.  I $L(X)<3 W ERR=ERR_1_U_"Referring Provider too short: "_X,BDGR("REFP")="" Q
  1.  I $L(X)>30 W ERR=ERR_1_U_"Referring Provider too long: "_X,BDGR("REFP")=""
  1.  Q
  1.  ;
  1. ATMD ; check attending and primary provider fields
  1.  NEW X,DIC,Y
  1.  ; check required attending physician
  1.  Q:BDGR("ATMD")=""   ;if not sent with edit, don't check
  1.  S X=$G(BDGR("ATMD")) I X="" S ERR=2_U_"Attending Provider Missing" Q
  1.  S DIC=200,DIC(0)="M"
  1.  S DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
  1.  D ^DIC I Y<1 S ERR=2_U_"Invalid Attending Provider: "_BDGR("ATMD") Q
  1.  ;
  1.  ; check primary provider (use attending if missing)
  1.  S X=$G(BGR("PRMD")) I X="" S BDGR("PRMD")=BDGR("ATMD") Q
  1.  S DIC=200,DIC(0)="M"
  1.  S DIC("S")="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
  1.  D ^DIC I Y<1 S ERR=2_U_"Invalid Primary Provider: "_BDGR("PRMD") Q
  1.  Q
  1.  ;
  1. CHECK(ARRAY) ; check common required fields
  1.  NEW X,Y,%DT
  1.  I '$G(BDGR("PAT")) Q 2_U_"Patient ID error"
  1.  S X=$G(BDGR("DATE")) I X'?7N1".".N D  I Y=-1 Q 2_U_"Date Error"
  1.  . S %DT="RX" D ^%DT Q:Y=-1
  1.  . S BDGR("DATE")=Y   ;reset date to FM format
  1.  I $$GET1^DIQ(200,+$G(BDGR("USER")),.01)="" Q 2_U_"User Error"
  1.  Q ""
  1.  ;
  1. FINDADM ; find admission based on acct # or admit date or current status
  1.  ;returns BDGV=visit ien & BDGCA=admission ien
  1.  ;
  1.  ; find visit based on acct #
  1.  NEW VST,X
  1.  S (VST,BDGV,BDGCA)=0
  1.  F  S VST=$O(^AUPNVSIT("AXT",BDGR("ACCT"),VST)) Q:'VST  Q:BDGV  D
  1.  . S X=$$GET1^DIQ(9000010,VST,.07,"I") I (X="H")!(X="O") D
  1.  .. ;check to make sure acct # on correct patient
  1.  .. I $P($G(^AUPNVSIT(VST,0)),U,5)=BDGR("PAT") S BDGV=VST
  1.  ;
  1.  ; if not found, try finding visit based on admit date
  1.  I 'BDGV S BDGV=$$VISIT^BDGF1(+BDGR("PAT"),+BDGR("ADMIT DATE"))
  1.  ;
  1.  ; if visit found, find admit entry
  1.  I BDGV S BDGCA=$O(^DGPM("AVISIT",BDGV,0))
  1.  ;
  1.  ; if still no visit found, try to find ADT event for admit date
  1.  I 'BDGV D
  1.  . S BDGCA=$O(^DGPM("AMV1",+BDGR("PAT"),+BDGR("ADMIT DATE"),0))
  1.  ;
  1.  ; if no admit entry found yet, use current entry
  1.  I 'BDGCA S BDGCA=$G(^DPT(+BDGR("PAT"),.105))
  1.  ;
  1.  ; if admit entry found, but not visit, try file 405
  1.  I BDGCA,'BDGV S BDGV=$$GET1^DIQ(405,BDGCA,.27,"I")
  1.  ;
  1.  Q