BDGAPI1 ; IHS/ANMC/LJF - PATIENT MOVEMENT API'S ; [ 06/19/2002 1:22 PM ]
;;5.3;PIMS;;APR 26, 2002
;
;See BDGAPI for details on variables
; Required for cancel function -
; BDGR("PAT") = patient ien
; BDGR("TRAN") = ADT transaction
; BDGR("ACCT") = outside account #
; BDGR("DATE") = event date/time
;
CANCEL(BDGR) ;EP; silent API to delete patient movement entries to file 405
NEW DGQUIET,BDGAPI,ERR
S DGQUIET=1 ;must be in quiet mode
S BDGAPI=1 ;let DGPMV rtns know using API
;
S ERR=$$CHECK^BDGAPI(.BDGR) I ERR Q ERR ;check common req fields
;
D @BDGR("TRAN") I ERR Q ERR
Q $G(ERR)
;
;
1 ; delete admission
NEW DGPMT,DGPMP,DFN,I,DGPMCA,DGPMDA,BDGN,X,DGPMAN,DA,DGPMN
S DGPMT=BDGR("TRAN"),DFN=BDGR("PAT"),ERR="",DGPMN=0
;
; find admission based on acct #
;6/19/2002 LJF9 (per Linda) change errors to warnings.
;S BDGN=$$CA I $E(ERR,1)=1 Q
S BDGN=$$CA I '$G(BDGN) Q ;IHS/ANMC/LJF 6/12/2002 if no IEN, quit no matter the reason
;
; set up BEFORE variables needed by event driver
S (DA,DGPMDA,DGPMCA)=BDGN,DGPMAN=$G(^DGPM(DA,0)) K %DT
S DGPMY=BDGR("ADMIT DATE"),DGPMP=DGPMAN
D VAR^DGPMV3 S DGPMER=0
;
; loop through other movements tied to admission and delete them
F DGI=DGPMDA:0 S DGI=$O(^DGPM("CA",DGPMDA,DGI)) Q:'DGI D
. I $D(^DGPM(DGI,0)) D
.. S DGPMTYP=$P(^DGPM(DGI,0),"^",2),DA=DGI,DIK="^DGPM("
.. S ^UTILITY("DGPM",$J,DGPMTYP,DA,"P")=^DGPM(DGI,0),^UTILITY("DGPM",$J,DGPMTYP,DA,"A")=""
.. S ^UTILITY("DGPM",$J,DGPMTYP,DA,"IHSP")=$G(^DGPM(DGI,"IHS"))
.. S ^UTILITY("DGPM",$J,DGPMTYP,DA,"IHSA")=""
.. D ^DIK
;
; kill any treating specialty entry tied to admission
I DGPMDA,$O(^DGPM("APHY",DGPMDA,0)) D
. S DIK="^DGPM(",DA=+$O(^DGPM("APHY",DGPMDA,0))
. I $D(^DGPM(+DA,0)) D
.. S ^UTILITY("DGPM",$J,6,DA,"P")=^DGPM(DA,0),^UTILITY("DGPM",$J,6,DA,"A")=""
.. S ^UTILITY("DGPM",$J,6,DA,"IHSA")=""
.. S ^UTILITY("DGPM",$J,6,DA,"IHSP")=$G(^DGPM(+DA,"IHS"))
.. S Y=DA D PRIOR^DGPMV36,^DIK S Y=DA D AFTER^DGPMV36
;
; now delete admission
S DIK="^DGPM(",DA=DGPMDA D ^DIK
;
; set AFTER variables for event driver
S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$G(^DGPM(+DGPMDA,0))
S ^UTILITY("DGPM",$J,DGPMT,DGPMDA,"IHSA")=$G(^DGPM(+DGPMDA,"IHS"))
;
S DGOK=0 F I=0:0 S I=$O(^UTILITY("DGPM",$J,I)) Q:'I F J=0:0 S J=$O(^UTILITY("DGPM",$J,I,J)) Q:'J I (^(J,"A")'=^("P"))!($G(^("IHSA"))'=$G(^("IHSP"))) S DGOK=1 Q
I DGOK D ^DGPMEVT ;Invoke Movement Event Driver
D Q^DGPMV3 ;clean up event driver variables
;
Q
;
3 ; delete discharge
NEW DGPMT,DGPMP,DFN,I,DGPMCA,DGPMDA,BDGN,X,IEN,BDGV,BDGCA
S DGPMT=BDGR("TRAN"),DFN=BDGR("PAT"),ERR=""
;
; find admission based on acct # or admit date or current admit
D FINDADM^BDGAPI2
I 'BDGCA S ERR=ERR_2_U_"Cannot find file 405 entry for visit attached to acct # "_$G(BDGR("ACCT"))_U Q
S DGPMCA=BDGCA
;
; now find discharge entry
S BDGN=$$GET1^DIQ(405,DGPMCA,.17,"I")
I 'BDGN S ERR=1_U_"No discharge associated with account # "_$G(BDGR("ACCT")) Q
I $O(^DGPM("APTT1",DFN,BDGR("DISCHARGE DATE"))) S ERR=1_U_"Can only delete discharge for last admission; discharge ien="_BDGN Q
;
; set up BEFORE variables needed by event driver
S DGPMDA=BDGN K %DT
S ^UTILITY("DGPM",$J,DGPMT,DGPMDA,"IHSP")=$G(^DGPM(DGPMDA,"IHS"))
S DGPMER=0,(^UTILITY("DGPM",$J,DGPMT,DGPMDA,"P"),DGPMP)=^DGPM(DGPMDA,0)
;
;Delete discharge, update admission mvt
S DGPMADM=DGPMCA D DD^DGPMVDL1 K DA
;
; set AFTER variables for event driver
S (^UTILITY("DGPM",$J,DGPMT,DGPMDA,"A"),DGPMA)=$G(^DGPM(+DGPMDA,0))
S ^UTILITY("DGPM",$J,DGPMT,DGPMDA,"IHSA")=$G(^DGPM(+DGPMDA,"IHS"))
;
S DGOK=0 F I=0:0 S I=$O(^UTILITY("DGPM",$J,I)) Q:'I F J=0:0 S J=$O(^UTILITY("DGPM",$J,I,J)) Q:'J I (^(J,"A")'=^("P"))!($G(^("IHSA"))'=$G(^("IHSP"))) S DGOK=1 Q
I DGOK D ^DGPMEVT ;Invoke Movement Event Driver
D Q^DGPMV3 ;clean up event driver variables
;
Q
;
;LJF9 - everything coming out of this subroutine is an error, not a warning
CA() ; find admission based on acct # or date
NEW X
S X=$O(^AUPNVSIT("AXT",+$G(BDGR("ACCT")),0))
I 'X S ERR=ERR_2_U_"Account # not in Visit file: "_$G(BDGR("ACCT"))_U
S BDGN=$O(^DGPM("AVISIT",+X,0))
;6/19/2002 LJF9 (per Linda) change errors to warnings
;I 'BDGN S ERR=ERR_2_U_"Cannot find file 405 entry for visit attached to acct # "_$G(BDGR("ACCT"))_U
;
; if cannot find using acct #, find via event date
I 'BDGN S BDGN=$O(^DGPM("APTT"_DGPMT,DFN,BDGR("DATE"),0))
;6/19/2002 LJF9 (per Linda) change errors to warnings
;I 'BDGN S ERR=1_U_"Cannot find entry using date or acct #; DATE="_BDGR("DATE")_" Acct #="_$G(BDGR("ACCT"))
I 'BDGN S ERR=2_U_"Cannot find entry using date or acct #; DATE="_BDGR("DATE")_" Acct #="_$G(BDGR("ACCT")) ;IHS/ANMC/LJF 6/12/2002 LJF9
Q $G(BDGN)
BDGAPI1 ; IHS/ANMC/LJF - PATIENT MOVEMENT API'S ; [ 06/19/2002 1:22 PM ]
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 ;See BDGAPI for details on variables
+4 ; Required for cancel function -
+5 ; BDGR("PAT") = patient ien
+6 ; BDGR("TRAN") = ADT transaction
+7 ; BDGR("ACCT") = outside account #
+8 ; BDGR("DATE") = event date/time
+9 ;
CANCEL(BDGR) ;EP; silent API to delete patient movement entries to file 405
+1 NEW DGQUIET,BDGAPI,ERR
+2 ;must be in quiet mode
SET DGQUIET=1
+3 ;let DGPMV rtns know using API
SET BDGAPI=1
+4 ;
+5 ;check common req fields
SET ERR=$$CHECK^BDGAPI(.BDGR)
IF ERR
QUIT ERR
+6 ;
+7 DO @BDGR("TRAN")
IF ERR
QUIT ERR
+8 QUIT $GET(ERR)
+9 ;
+10 ;
1 ; delete admission
+1 NEW DGPMT,DGPMP,DFN,I,DGPMCA,DGPMDA,BDGN,X,DGPMAN,DA,DGPMN
+2 SET DGPMT=BDGR("TRAN")
SET DFN=BDGR("PAT")
SET ERR=""
SET DGPMN=0
+3 ;
+4 ; find admission based on acct #
+5 ;6/19/2002 LJF9 (per Linda) change errors to warnings.
+6 ;S BDGN=$$CA I $E(ERR,1)=1 Q
+7 ;IHS/ANMC/LJF 6/12/2002 if no IEN, quit no matter the reason
SET BDGN=$$CA
IF '$GET(BDGN)
QUIT
+8 ;
+9 ; set up BEFORE variables needed by event driver
+10 SET (DA,DGPMDA,DGPMCA)=BDGN
SET DGPMAN=$GET(^DGPM(DA,0))
KILL %DT
+11 SET DGPMY=BDGR("ADMIT DATE")
SET DGPMP=DGPMAN
+12 DO VAR^DGPMV3
SET DGPMER=0
+13 ;
+14 ; loop through other movements tied to admission and delete them
+15 FOR DGI=DGPMDA:0
SET DGI=$ORDER(^DGPM("CA",DGPMDA,DGI))
IF 'DGI
QUIT
Begin DoDot:1
+16 IF $DATA(^DGPM(DGI,0))
Begin DoDot:2
+17 SET DGPMTYP=$PIECE(^DGPM(DGI,0),"^",2)
SET DA=DGI
SET DIK="^DGPM("
+18 SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"P")=^DGPM(DGI,0)
SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"A")=""
+19 SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"IHSP")=$GET(^DGPM(DGI,"IHS"))
+20 SET ^UTILITY("DGPM",$JOB,DGPMTYP,DA,"IHSA")=""
+21 DO ^DIK
End DoDot:2
End DoDot:1
+22 ;
+23 ; kill any treating specialty entry tied to admission
+24 IF DGPMDA
IF $ORDER(^DGPM("APHY",DGPMDA,0))
Begin DoDot:1
+25 SET DIK="^DGPM("
SET DA=+$ORDER(^DGPM("APHY",DGPMDA,0))
+26 IF $DATA(^DGPM(+DA,0))
Begin DoDot:2
+27 SET ^UTILITY("DGPM",$JOB,6,DA,"P")=^DGPM(DA,0)
SET ^UTILITY("DGPM",$JOB,6,DA,"A")=""
+28 SET ^UTILITY("DGPM",$JOB,6,DA,"IHSA")=""
+29 SET ^UTILITY("DGPM",$JOB,6,DA,"IHSP")=$GET(^DGPM(+DA,"IHS"))
+30 SET Y=DA
DO PRIOR^DGPMV36
DO ^DIK
SET Y=DA
DO AFTER^DGPMV36
End DoDot:2
End DoDot:1
+31 ;
+32 ; now delete admission
+33 SET DIK="^DGPM("
SET DA=DGPMDA
DO ^DIK
+34 ;
+35 ; set AFTER variables for event driver
+36 SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$GET(^DGPM(+DGPMDA,0))
+37 SET ^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"IHSA")=$GET(^DGPM(+DGPMDA,"IHS"))
+38 ;
+39 SET DGOK=0
FOR I=0:0
SET I=$ORDER(^UTILITY("DGPM",$JOB,I))
IF 'I
QUIT
FOR J=0:0
SET J=$ORDER(^UTILITY("DGPM",$JOB,I,J))
IF 'J
QUIT
IF (^(J,"A")'=^("P"))!($GET(^("IHSA"))'=$GET(^("IHSP")))
SET DGOK=1
QUIT
+40 ;Invoke Movement Event Driver
IF DGOK
DO ^DGPMEVT
+41 ;clean up event driver variables
DO Q^DGPMV3
+42 ;
+43 QUIT
+44 ;
3 ; delete discharge
+1 NEW DGPMT,DGPMP,DFN,I,DGPMCA,DGPMDA,BDGN,X,IEN,BDGV,BDGCA
+2 SET DGPMT=BDGR("TRAN")
SET DFN=BDGR("PAT")
SET ERR=""
+3 ;
+4 ; find admission based on acct # or admit date or current admit
+5 DO FINDADM^BDGAPI2
+6 IF 'BDGCA
SET ERR=ERR_2_U_"Cannot find file 405 entry for visit attached to acct # "_$GET(BDGR("ACCT"))_U
QUIT
+7 SET DGPMCA=BDGCA
+8 ;
+9 ; now find discharge entry
+10 SET BDGN=$$GET1^DIQ(405,DGPMCA,.17,"I")
+11 IF 'BDGN
SET ERR=1_U_"No discharge associated with account # "_$GET(BDGR("ACCT"))
QUIT
+12 IF $ORDER(^DGPM("APTT1",DFN,BDGR("DISCHARGE DATE")))
SET ERR=1_U_"Can only delete discharge for last admission; discharge ien="_BDGN
QUIT
+13 ;
+14 ; set up BEFORE variables needed by event driver
+15 SET DGPMDA=BDGN
KILL %DT
+16 SET ^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"IHSP")=$GET(^DGPM(DGPMDA,"IHS"))
+17 SET DGPMER=0
SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"P"),DGPMP)=^DGPM(DGPMDA,0)
+18 ;
+19 ;Delete discharge, update admission mvt
+20 SET DGPMADM=DGPMCA
DO DD^DGPMVDL1
KILL DA
+21 ;
+22 ; set AFTER variables for event driver
+23 SET (^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"A"),DGPMA)=$GET(^DGPM(+DGPMDA,0))
+24 SET ^UTILITY("DGPM",$JOB,DGPMT,DGPMDA,"IHSA")=$GET(^DGPM(+DGPMDA,"IHS"))
+25 ;
+26 SET DGOK=0
FOR I=0:0
SET I=$ORDER(^UTILITY("DGPM",$JOB,I))
IF 'I
QUIT
FOR J=0:0
SET J=$ORDER(^UTILITY("DGPM",$JOB,I,J))
IF 'J
QUIT
IF (^(J,"A")'=^("P"))!($GET(^("IHSA"))'=$GET(^("IHSP")))
SET DGOK=1
QUIT
+27 ;Invoke Movement Event Driver
IF DGOK
DO ^DGPMEVT
+28 ;clean up event driver variables
DO Q^DGPMV3
+29 ;
+30 QUIT
+31 ;
+32 ;LJF9 - everything coming out of this subroutine is an error, not a warning
CA() ; find admission based on acct # or date
+1 NEW X
+2 SET X=$ORDER(^AUPNVSIT("AXT",+$GET(BDGR("ACCT")),0))
+3 IF 'X
SET ERR=ERR_2_U_"Account # not in Visit file: "_$GET(BDGR("ACCT"))_U
+4 SET BDGN=$ORDER(^DGPM("AVISIT",+X,0))
+5 ;6/19/2002 LJF9 (per Linda) change errors to warnings
+6 ;I 'BDGN S ERR=ERR_2_U_"Cannot find file 405 entry for visit attached to acct # "_$G(BDGR("ACCT"))_U
+7 ;
+8 ; if cannot find using acct #, find via event date
+9 IF 'BDGN
SET BDGN=$ORDER(^DGPM("APTT"_DGPMT,DFN,BDGR("DATE"),0))
+10 ;6/19/2002 LJF9 (per Linda) change errors to warnings
+11 ;I 'BDGN S ERR=1_U_"Cannot find entry using date or acct #; DATE="_BDGR("DATE")_" Acct #="_$G(BDGR("ACCT"))
+12 ;IHS/ANMC/LJF 6/12/2002 LJF9
IF 'BDGN
SET ERR=2_U_"Cannot find entry using date or acct #; DATE="_BDGR("DATE")_" Acct #="_$GET(BDGR("ACCT"))
+13 QUIT $GET(BDGN)
