SDAMEVT3 ;ALB/CAW - Disposition Event Driver Utilities ; 11/2/00 8:40am
;;5.3;Scheduling;**15,217**;Aug 13, 1993
;
BEFORE(DFN,SDDT,SDEVT,SDHDL) ;
D CAPTURE("BEFORE",.DFN,.SDDT,.SDEVT,.SDHDL)
Q
;
AFTER(DFN,SDDT,SDEVT,SDHDL) ;
N SDDA,SDIS,DA,DR,DE,DQ,DIV,DIE,SDVSIT,SDINS,SDIV,X
;
S SDIS=$G(^DPT(DFN,"DIS",9999999-SDDT,0))
; -- is the disposition good for opc credit?
I ($P(SDIS,U,2)=0!($P(SDIS,U,2)=1)),$P(SDIS,U,6),'$P($G(^SCE(+$P(SDIS,U,18),0)),U,7) D
.I SDEVT=9 W !!,*7,">>> This Disposition must be checked out."
.D RESET(DFN,9999999-SDDT,SDHDL)
.I $P(SDIS,U,18) D EN^SDCODEL($P(SDIS,U,18),1,SDHDL)
;
; -- is the disposition 'still' good for opc credit?
I $P(SDIS,U,2)'=0,$P(SDIS,U,2)'=1,$P(SDIS,U,18) D
.I '$$ASK D RESET(DFN,9999999-SDDT,SDHDL) Q
.D EN^SDCODEL($P(SDIS,U,18),1,SDHDL)
;
; -- capture 'after' data
D CAPTURE("AFTER",.DFN,.SDDT,.SDEVT,.SDHDL)
;
; -- has division changed
I $P(^TMP("SDEVT",$J,SDHDL,3,"DIS",0,"BEFORE"),U,4)'=$P(^("AFTER"),U,4) S X=^("AFTER") I $P(X,U,18) S SDIV=$P(X,U,4),SDOE=$P(X,U,18) D Q
.;
.;-- is a new visit entry needed
.I $P($G(^AUPNVSIT(+$P($G(^SCE(SDOE,0)),U,5),0)),U,6) S SDINS=$P(^(0),U,6) I SDINS'=$P($G(^DG(40.8,SDIV,0)),U,7) D
..D ARRAY^SDVSIT(DFN,SDDT,.SDDA,.SDIS,.SDVSIT)
..D VISIT^SDVSIT0(.SDDT,.SDVSIT)
..I SDVSIT("VST") S DIE="^SCE(",DR=".05////"_SDVSIT("VST"),DA=SDOE D ^DIE
..D OE^SDAMEVT("AFTER",3,SDOE,SDHDL)
; If division has not changed AND patient has an Outpatient Encounter
; display Hospital Disposition Location
S X=$G(^TMP("SDEVT",$J,SDHDL,3,"DIS",0,"AFTER")) I $P(X,U,18) S SDIV=$P(X,U,4),SDOE=$P(X,U,18) D
.N PREVST,DIC,DA,DR,DIQ,DHL,Y,OK
.S OK=0
.S DIC="409.68",DR=".05",DA=SDOE,DIQ="PREVST(",DIQ(0)="I" D EN^DIQ1
.F D Q:OK=1 ; Get Disposition Hospital Location
..S PREVST(0)=$G(PREVST("409.68",SDOE,".05","I"))
..S DIC=9000010,DA=PREVST(0),DR=".22",DIQ="DHL(",DIQ(0)="EI" D EN^DIQ1
..; Ask for Hospital location from those that can disposition
..S DA(1)=1,DIC="^PX(815,1,""DHL"",",DIC("P")=$P(^DD(815,401,0),"^",2)
..S DIC("B")=$G(DHL(9000010,PREVST(0),".22","E")) ; DHLocation
..S DIC(0)="AEOQ" D ^DIC
..I Y<0 W !!,$C(7),"Disposition Hospital Location is required." Q
..S DR=".22////"_$P(Y,"^",2),DIE=9000010,DA=PREVST(0)
..D ^DIE
..S OK=1
Q
;
RESET(DFN,SDIDT,SDHDL) ;Reset Disposition Status
N DA,DE,DQ,DIE,DR,SDOSTA
S SDOSTA=$P($G(^TMP("SDEVT",$J,SDHDL,3,"DIS",0,"BEFORE")),"^",2)
I $G(SDOSTA)]"" D
.W !!,">>> Changing status back to ",$P($P(^DD(2.101,1,0),SDOSTA_":",2),";"),"..."
.S DA=SDIDT,DA(1)=DFN,DR="1////"_SDOSTA
.S DIE="^DPT("_DFN_",""DIS""," D ^DIE
.W "done"
Q
;
ASK() ;Ask if user is sure they want to change the disposition status
N DIR,DTOUT,DUOUT,Y
W !!,*7,">>> Changing the status of this disposition will delete any check out",!?4,"related information. This information may include add/edits,",!?4,"classifications, providers and diagnoses."
S DIR("A")="Are you sure you want to change the status"
S DIR("B")="NO",DIR(0)="Y" W ! D ^DIR
Q +$G(Y)
;
CAPTURE(SDCAP,DFN,SDDT,SDEVT,SDHDL) ;
N SDDA,Z
S SDDA=9999999-SDDT
S (Z,^TMP("SDEVT",$J,SDHDL,3,"DIS",0,SDCAP))=$G(^DPT(DFN,"DIS",SDDA,0))
D:$P(Z,U,18) OE^SDAMEVT(SDCAP,3,+$P(Z,U,18),SDHDL)
Q
;
EVT(DFN,SDDT,SDEVT,SDHDL) ;
D AFTER(.DFN,.SDDT,.SDEVT,SDHDL)
D EVTGO^SDAMEVT2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMEVT3 3371 printed Apr 09, 2024@21:50:39 Page 2
SDAMEVT3 ;ALB/CAW - Disposition Event Driver Utilities ; 11/2/00 8:40am
+1 ;;5.3;Scheduling;**15,217**;Aug 13, 1993
+2 ;
BEFORE(DFN,SDDT,SDEVT,SDHDL) ;
+1 DO CAPTURE("BEFORE",.DFN,.SDDT,.SDEVT,.SDHDL)
+2 QUIT
+3 ;
AFTER(DFN,SDDT,SDEVT,SDHDL) ;
+1 NEW SDDA,SDIS,DA,DR,DE,DQ,DIV,DIE,SDVSIT,SDINS,SDIV,X
+2 ;
+3 SET SDIS=$GET(^DPT(DFN,"DIS",9999999-SDDT,0))
+4 ; -- is the disposition good for opc credit?
+5 IF ($PIECE(SDIS,U,2)=0!($PIECE(SDIS,U,2)=1))
IF $PIECE(SDIS,U,6)
IF '$PIECE($GET(^SCE(+$PIECE(SDIS,U,18),0)),U,7)
Begin DoDot:1
+6 IF SDEVT=9
WRITE !!,*7,">>> This Disposition must be checked out."
+7 DO RESET(DFN,9999999-SDDT,SDHDL)
+8 IF $PIECE(SDIS,U,18)
DO EN^SDCODEL($PIECE(SDIS,U,18),1,SDHDL)
End DoDot:1
+9 ;
+10 ; -- is the disposition 'still' good for opc credit?
+11 IF $PIECE(SDIS,U,2)'=0
IF $PIECE(SDIS,U,2)'=1
IF $PIECE(SDIS,U,18)
Begin DoDot:1
+12 IF '$$ASK
DO RESET(DFN,9999999-SDDT,SDHDL)
QUIT
+13 DO EN^SDCODEL($PIECE(SDIS,U,18),1,SDHDL)
End DoDot:1
+14 ;
+15 ; -- capture 'after' data
+16 DO CAPTURE("AFTER",.DFN,.SDDT,.SDEVT,.SDHDL)
+17 ;
+18 ; -- has division changed
+19 IF $PIECE(^TMP("SDEVT",$JOB,SDHDL,3,"DIS",0,"BEFORE"),U,4)'=$PIECE(^("AFTER"),U,4)
SET X=^("AFTER")
IF $PIECE(X,U,18)
SET SDIV=$PIECE(X,U,4)
SET SDOE=$PIECE(X,U,18)
Begin DoDot:1
+20 ;
+21 ;-- is a new visit entry needed
+22 IF $PIECE($GET(^AUPNVSIT(+$PIECE($GET(^SCE(SDOE,0)),U,5),0)),U,6)
SET SDINS=$PIECE(^(0),U,6)
IF SDINS'=$PIECE($GET(^DG(40.8,SDIV,0)),U,7)
Begin DoDot:2
+23 DO ARRAY^SDVSIT(DFN,SDDT,.SDDA,.SDIS,.SDVSIT)
+24 DO VISIT^SDVSIT0(.SDDT,.SDVSIT)
+25 IF SDVSIT("VST")
SET DIE="^SCE("
SET DR=".05////"_SDVSIT("VST")
SET DA=SDOE
DO ^DIE
+26 DO OE^SDAMEVT("AFTER",3,SDOE,SDHDL)
End DoDot:2
End DoDot:1
QUIT
+27 ; If division has not changed AND patient has an Outpatient Encounter
+28 ; display Hospital Disposition Location
+29 SET X=$GET(^TMP("SDEVT",$JOB,SDHDL,3,"DIS",0,"AFTER"))
IF $PIECE(X,U,18)
SET SDIV=$PIECE(X,U,4)
SET SDOE=$PIECE(X,U,18)
Begin DoDot:1
+30 NEW PREVST,DIC,DA,DR,DIQ,DHL,Y,OK
+31 SET OK=0
+32 SET DIC="409.68"
SET DR=".05"
SET DA=SDOE
SET DIQ="PREVST("
SET DIQ(0)="I"
DO EN^DIQ1
+33 ; Get Disposition Hospital Location
FOR
Begin DoDot:2
+34 SET PREVST(0)=$GET(PREVST("409.68",SDOE,".05","I"))
+35 SET DIC=9000010
SET DA=PREVST(0)
SET DR=".22"
SET DIQ="DHL("
SET DIQ(0)="EI"
DO EN^DIQ1
+36 ; Ask for Hospital location from those that can disposition
+37 SET DA(1)=1
SET DIC="^PX(815,1,""DHL"","
SET DIC("P")=$PIECE(^DD(815,401,0),"^",2)
+38 ; DHLocation
SET DIC("B")=$GET(DHL(9000010,PREVST(0),".22","E"))
+39 SET DIC(0)="AEOQ"
DO ^DIC
+40 IF Y<0
WRITE !!,$CHAR(7),"Disposition Hospital Location is required."
QUIT
+41 SET DR=".22////"_$PIECE(Y,"^",2)
SET DIE=9000010
SET DA=PREVST(0)
+42 DO ^DIE
+43 SET OK=1
End DoDot:2
if OK=1
QUIT
End DoDot:1
+44 QUIT
+45 ;
RESET(DFN,SDIDT,SDHDL) ;Reset Disposition Status
+1 NEW DA,DE,DQ,DIE,DR,SDOSTA
+2 SET SDOSTA=$PIECE($GET(^TMP("SDEVT",$JOB,SDHDL,3,"DIS",0,"BEFORE")),"^",2)
+3 IF $GET(SDOSTA)]""
Begin DoDot:1
+4 WRITE !!,">>> Changing status back to ",$PIECE($PIECE(^DD(2.101,1,0),SDOSTA_":",2),";"),"..."
+5 SET DA=SDIDT
SET DA(1)=DFN
SET DR="1////"_SDOSTA
+6 SET DIE="^DPT("_DFN_",""DIS"","
DO ^DIE
+7 WRITE "done"
End DoDot:1
+8 QUIT
+9 ;
ASK() ;Ask if user is sure they want to change the disposition status
+1 NEW DIR,DTOUT,DUOUT,Y
+2 WRITE !!,*7,">>> Changing the status of this disposition will delete any check out",!?4,"related information. This information may include add/edits,",!?4,"classifications, providers and diagnoses."
+3 SET DIR("A")="Are you sure you want to change the status"
+4 SET DIR("B")="NO"
SET DIR(0)="Y"
WRITE !
DO ^DIR
+5 QUIT +$GET(Y)
+6 ;
CAPTURE(SDCAP,DFN,SDDT,SDEVT,SDHDL) ;
+1 NEW SDDA,Z
+2 SET SDDA=9999999-SDDT
+3 SET (Z,^TMP("SDEVT",$JOB,SDHDL,3,"DIS",0,SDCAP))=$GET(^DPT(DFN,"DIS",SDDA,0))
+4 if $PIECE(Z,U,18)
DO OE^SDAMEVT(SDCAP,3,+$PIECE(Z,U,18),SDHDL)
+5 QUIT
+6 ;
EVT(DFN,SDDT,SDEVT,SDHDL) ;
+1 DO AFTER(.DFN,.SDDT,.SDEVT,SDHDL)
+2 DO EVTGO^SDAMEVT2
+3 QUIT
