SCENIA2 ;ALB/SCK - INCOMPLETE ENCOUNTER ERROR DISPLAY PROTOCOLS, CONT. ; OCT 21, 1998
;;5.3;Scheduling;**66,132,158,560**;AUG 13, 1993;Build 8
;
EVT1(SDXMT,INF) ; Returns ifn for ^SC(clinic,"S",date,1,ifn)
N SINDX,SDDA
;
S SINDX=0 F S SINDX=$O(^SC(INF("CLINIC"),"S",INF("ENCOUNTER"),1,SINDX)) Q:'SINDX>0 D Q:$D(SDDA)
. I +^SC(INF("CLINIC"),"S",INF("ENCOUNTER"),1,SINDX,0)=INF("DFN") S SDDA=SINDX
Q $G(SDDA)
;
EI ; Entry point for the SCENI ENCOUNTER INFORMATION protocol
I '$D(SD53P158) N SD53P158 S SD53P158="LM" ; Called via LM.
I '$D(^XUSEC("SCENI ENCOUNTER EDIT",DUZ)) D Q
. W !,$C(7),"You do not have this security key, contact your supervisor."
;
N SDATA,SCEN,SDXMT,SCXER,SDOE,SCINF,SCSTAT,SDEVT,SDHDL,SDDA,SCELAP,SCSTPLC,OLDSC,SDQUIT,SDLOG
N SDFLAG,SDVST S SDFLAG=0,SDVST="" ;SD*560
;
K PARENT,VISIT
D HDLKILL^SDAMEVT
S SDXMT=$G(^TMP("SCENI XMT",$J,0)) Q:'SDXMT
S SCSTAT=$$OPENC^SCUTIE1(SDXMT,"SCINF")
I SCSTAT<0 D G EIQ
. W !!,$C(7),"Entry "_$P(^SD(409.73,SDXMT,0),U),?5,$G(SCINF("ERROR"))
. D PAUSE^VALM1
;
I SCSTAT>0 D G EIQ
. W !!,$C(7),"This is a deleted entry. Encounter information cannot be changed."
. D PAUSE^VALM1
;
S DFN=SCINF("DFN")
S SDOE=$P(^SD(409.73,SDXMT,0),U,2)
S SDHDL=$$HANDLE^SDAMEVT($P($G(^SCE(SDOE,0)),U,8)),SDDA=$$EVT1(SDXMT,.SCINF)
Q:SDHDL']""
;
S:'SDDA SDFLAG=1 ;SD*5.3*560 encounter not associated w/sched appt
S SDATA=SDDA_"^"_DFN_"^"_SCINF("ENCOUNTER")_"^"_SCINF("CLINIC")
S SDQUIT=0
;
L +^SCE(SDOE):0 I '$T D G EIQ
. W !?5,$CHAR(7),"Another user is editing this entry"
I SD53P158="LM" D FULL^VALM1
K DIRUT
W !
D BEFORE^SDAMEVT(.SDATA,DFN,SCINF("ENCOUNTER"),SCINF("CLINIC"),SDDA,SDHDL)
;
K OLDSC,SDEDT S OLDSC=+$P($G(^SCE(SDOE,0)),U,3),SDEDT=$P(^(0),U,1)
EI1 S DIR(0)="409.68,.03",DA=SDOE
D ^DIR K DIR G:$D(DIRUT)!(Y="") EIQ
;SD*560 do not allow if Inactive at time of encounter
I $P(^DIC(40.7,+Y,0),U,3)'="" I $P(^(0),U,3)'>SDEDT D G EI1
.W !!,"Sorry, that Stop Code was INACTIVE at the time of the selected encounter.",!
;SD*560 do not allow if Restriction Type is "S"
I $P(^DIC(40.7,+Y,0),U,6)="S" I $P(^(0),U,7)'>SDEDT D G EI1
.W !!,"Sorry, the Restriction Type for that Stop Code is 'S' (secondary only).",!,"You cannot select this stop code.",!
S $P(SCSTPLC,U)=+Y
D SET(+Y,.03,SDOE)
I SDFLAG I OLDSC'=+Y D SET1(+Y,SDOE,1) ;SD*560 set Visit & Trans flag
;
K OLDDV S OLDDV=+$P($G(^SCE(SDOE,0)),U,11) ;SD*560 get current Division
S DIR(0)="409.68,.11",DA=SDOE
D ^DIR K DIR G:$D(DIRUT)!(Y="") A1
S $P(SCSTPLC,U,2)=+Y
D SET(+Y,.11,SDOE)
I OLDDV'=+Y D SETDV(+Y,SDOE) ;SD*560 set Visit & Trans flag
K OLDDV
;
; ** Display current Appt. Type and Elig. Codes
N SD1,OLDAT S (SD1,OLDAT)=$P($G(^SCE(SDOE,0)),U,10) ;SD*560 add OLDAT
W !!!,$C(7),"Current Appointment Type for Encounter: "_$S($G(SD1):$P(^SD(409.1,SD1,0),U),1:"")
K SD1,OLDELG S (SD1,OLDELG)=$P($G(^SCE(SDOE,0)),U,13) ;sD*560 add OLDELG
W !,"Current Eligibility for Encounter: "_$S($G(SD1):$P(^DIC(8,SD1,0),U),1:""),!
;
S DIR(0)="YA",DIR("B")="NO",DIR("A")="Change Eligibility/Appointment type? " D ^DIR K DIR G:$D(DIRUT)!(Y=0) A1
;
;SD*560 if SC Indicator in Visit equals 1 (Service Connected) do not allow edit of Appt Type or Eligibility
I $P(^SCE(SDOE,0),U,10)'=10 S SDVST=$P(^SCE(SDOE,0),U,5) I $D(^AUPNVSIT(SDVST,800)) I +$G(^(800))=1 D G A1
.W !!,"The Visit associated with the selected encounter is SERVICE CONNECTED."
.W !,"You cannot edit the Appointment Type or Eligibility for this encounter.",!
;
W !,"The following are system defaults only.",!
;
S SCELAP=$$ELAP^SDPCE(DFN,SCINF("CLINIC"))
;
N SDPRIM
S SDPRIM=$$ONEELIG
;if only a primary ask if they want to change to it and change
I SDPRIM,+SDPRIM'=SD1 DO
.N DIR
.S DIR(0)="YA",DIR("B")="YES"
.S DIR("A",1)="There is only a primary eligibility for this patient: "_$P(SDPRIM,U,2)
.S DIR("A")="Do you wish to change the encounter to this? "
.S DIR("?")="No other Eligibilities are selectable."
.S DIR("?",1)="YES will result in the current primary Eligibility being used for the encounter."
.S DIR("?",2)="NO will result in the encounter's Eligibility being left the same."
.D ^DIR
.I Y=1 S $P(SCELAP,U,1)=+SDPRIM,$P(SCELAP,U,2)=$P(SDPRIM,U,2)
.E S $P(SCELAP,U,1)=SD1,$P(SCELAP,U,2)=$P($G(^DIC(8,+SD1,0)),U,1)
.Q
;
D SET(+SCELAP,.13,SDOE)
;SD*560 if Elig edited on non-appt encounter, update Visit & Trans flag
I SDFLAG I OLDELG'=+SCELAP D SET1(+SCELAP,SDOE,2)
D SET(+$P(SCELAP,U,3),.1,SDOE)
;
A1 D RESYNC(SCSTPLC,$G(SCELAP),SDOE,OLDSC,DFN)
D LOGDATA^SDAPIAP(SDOE,.SDLOG)
D AFTER^SDAMEVT(.SDATA,DFN,SCINF("ENCOUNTER"),SCINF("CLINIC"),SDDA,SDHDL)
;
D EVT^SDAMEVT(.SDATA,5,0,SDHDL)
I '$D(SDOK) D I $G(RTN)<0 G EIQ
. S RTN=$$VALIDATE^SCMSVUT2(SDXMT)
. I RTN<0 D ERMSG^SCENIA1(5) Q
. S RTN=$$SETRFLG^SCENIA1(SDXMT)
. I RTN<0 D ERMSG^SCENIA1(3) Q
;SD*560 if appt type edited, check if it was allowed and changed
I $D(SCELAP) I OLDAT'=+$P(SCELAP,U,3) S POP=0 D
.I OLDAT=10 I +$P(SCELAP,U,3)=11 D Q:POP
..I +$P(^SCE(SDOE,0),U,10)'=11 I $D(^AUPNVSIT($P(^SCE(SDOE,0),U,5),800)) I +$G(^(800),"")=0 D A1WRT,A2WRT S POP=1 Q
.I OLDAT=10 I +$P(SCELAP,U,3)'=11 D Q:POP
..I +$P(^SCE(SDOE,0),U,10)=11 I $D(^AUPNVSIT($P(^SCE(SDOE,0),U,5),800)) I +$G(^(800),"")=1 D A1WRT1,A2WRT S POP=1 Q
.Q:OLDAT'=$P(^SCE(SDOE,0),U,10)
.I OLDAT'=11 I $P(SCELAP,U,3)=11 D A1WRT Q
K POP
;SD*560 if Appt Type edit accepted on non-appt encounter set encounter to retrans
I SDFLAG I $D(SCELAP) I OLDAT'=+$P(SCELAP,U,3) D
.S XMIT="",XMIT=$$FINDXMIT^SCDXFU01(SDOE) ;get IEN for file 409.73
.D:XMIT STREEVNT^SCDXFU01(XMIT,2) ;set trans event to edit
.D:XMIT XMITFLAG^SCDXFU01(XMIT) ;set flag for trans to Yes
.K XMIT,OLDAT
I $D(SDOK) S SDOK=1
W !,"Updating Completed." ;SD*560 moved from RESYNC
L -^SCE(SDOE):0
EIQ K OLDSC,OLDAT,OLDELG,SDFLAG K:$D(POP) POP
Q
;
A1WRT ;SD*560 write warning message, if applicable
W !!,"The Visit entry associated with the selected encounter is NOT SERVICE CONNECTED."
W !,"You cannot change the Appointment Type to SERVICE CONNECTED.",!
Q
;
A1WRT1 ;SD*560 write warning message if Service Connected
W !!,"The Visit entry associated with the selected encounter is SERVICE CONNECTED."
W !,"You cannot change the Appointment Type to non-SERVICE CONNECTED."
Q
;
A2WRT ;SD*560 display current Appointment Type per update.
W !,"Appointment Type has been updated to ",$P(^SD(409.1,$P(^SCE(SDOE,0),U,10),0),U,1),".",!
Q
;
SET(SDVAL,SDFLD,DA) ; Set updated entry into file #409.68.
;
S ^TMP("SCENI EDIN",$J,409.68,DA_",",SDFLD)=SDVAL
D FILE^DIE("K","^TMP(""SCENI EDIN"",$J)")
I $D(^TMP("DIERR",$J,1)) W !!,"???"
K ^TMP("SCENI EDIN",$J),^TMP("DIERR",$J)
Q
;
SET1(SDVAL,SDOE,SEDT) ;SD*560 set Visit & Trans Flag for non-appt encounter
;SEDT=1 primary stop code edit
;SEDT=2 eligibility edit
N SDVST,VDT,SDCVST
S SDVST=$P(^SCE(SDOE,0),U,5) Q:'SDVST
S VDT=$$NOW^XLFDT
S DA=SDVST,DIE="^AUPNVSIT("
I SEDT=1 S DR=".08////^S X=SDVAL;.13////^S X=VDT" D ^DIE
I SEDT=2 S DR=".21////^S X=SDVAL;.13////^S X=VDT" D ^DIE
;check for credit Visit and update, if applicable
I $O(^AUPNVSIT("AD",SDVST,"")) S SDCVST=$O(^AUPNVSIT("AD",SDVST,"")) D
.Q:SEDT=1 ;do not update if primary stop code edit
.K DA,DR
.S DA=SDCVST
.S DR=".21////^S X=SDVAL;.13////^S X=VDT" D ^DIE
S XMIT="",XMIT=$$FINDXMIT^SCDXFU01(SDOE) ;get IEN for file 409.73
D:XMIT STREEVNT^SCDXFU01(XMIT,2) ;set trans event to edit
D:XMIT XMITFLAG^SCDXFU01(XMIT) ;set flag for trans required to Yes
K XMIT,DA,DR,X,DIE
Q
;
SETDV(SDVAL,SDOE) ;SD*560 set Visit & Trans Flag when Division edited
N SDVST,VDT,SDNDV,SDCVST
S SDVST=$P(^SCE(SDOE,0),U,5) Q:'SDVST
S SDNDV=+$P($G(^DG(40.8,SDVAL,0)),U,7) ;get pointer to Institution file
S VDT=$$NOW^XLFDT
S DA=SDVST,DIE="^AUPNVSIT("
S DR=".06////^S X=SDNDV;.13////^S X=VDT" D ^DIE
;check for credit Visit and update, if applicable
I $O(^AUPNVSIT("AD",SDVST,"")) S SDCVST=$O(^AUPNVSIT("AD",SDVST,"")) D
.K DA,DR
.S DA=SDCVST
.S DR=".06////^S X=SDNDV;.13////^S X=VDT" D ^DIE
S XMIT="",XMIT=$$FINDXMIT^SCDXFU01(SDOE) ;get IEN for file 409.73
D:XMIT STREEVNT^SCDXFU01(XMIT,2) ;set trans event to edit
D:XMIT XMITFLAG^SCDXFU01(XMIT) ;set flag for trans required to Yes
K DA,DR,DIE,SD408,XMIT
Q
;
UPDENC ; Update Outpatient Encounter Option entry point
N SDOE,SDXMT,DFN,SDOK
N SD53P158 S SD53P158="OPT" ;Entered via menu option.
;
S SDOK=0
K ^TMP("SCENI XMT",$J)
S DIR(0)="PA^409.68:EMQ",DIR("S")="I $D(^SD(409.73,""AENC"",Y))"
S DIR("A")="Select Encounter to update: "
S DIR("?")="Enter partial name, last four, or date of encounter."
S DIR("??")="^S %DT=""PX"" D HELP^%DTC"
D ^DIR K DIR G UPDQ:$D(DIRUT)
;
S SDOE=+Y
S SDXMT=$O(^SD(409.73,"AENC",SDOE,0))
S ^TMP("SCENI XMT",$J,0)=SDXMT
D EI
UPDQ ;
K DFN
Q
;
RESYNC(STPL,SCELP,SDOE,SCOLD,SDFN) ;
N SDOEC,SDCDT
;
; ** Update any child encounters and for each child encounter, search for
; any entries in the Scheduling Visits File, #409.5. If there is a
; match, update then entry in #409.5
;
;everthing else
S SDOEC=""
F S SDOEC=$O(^SCE("APAR",SDOE,SDOEC)) Q:'SDOEC D
. I +$P($G(^SCE(SDOE,0)),U,13)>0 D SET(+$P($G(^SCE(SDOE,0)),U,13),.13,SDOEC)
. I +$P($G(^SCE(SDOE,0)),U,10)>0 D SET(+$P($G(^SCE(SDOE,0)),U,10),.1,SDOEC)
. I +$P($G(^SCE(SDOE,0)),U,11)>0 D SET(+$P($G(^SCE(SDOE,0)),U,11),.11,SDOEC)
. I "2"[+$P($G(^SCE(SDOEC,0)),U,8),($P($G(^SCE(SDOEC,0)),U,3)=SCOLD) D SET(+$P($G(^SCE(SDOE,0)),U,3),.03,SDOEC)
;
; ** Update the entry in the Clinic Appointment multiple for the encounter
S SDOEDT=$P($G(^SCE(SDOE,0)),U),SDCLN=$P($G(^(0)),U,4)
S SDN1=0 F S SDN1=$O(^SC(SDCLN,"S",SDOEDT,1,SDN1)) Q:'SDN1 D
. I $P($G(^SC(SDCLN,"S",SDOEDT,1,SDN1,0)),U)=SDFN D
.. S DIE="^SC(SDCLN,""S"",SDOEDT,1,",DA(2)=SDCLN,DA(1)=SDOEDT,DA=SDN1
.. S DR="30////"_$P(SCELP,U)
.. L +^SC(SDCLN,"S",SDOEDT,1,SDN1):$S($G(DILOCKTM)>0:DILOCKTM,1:5) ;SD*560 added required timeout
.. D ^DIE K DIE,DR,DA
.. L -^SC(SDCLN,"S",SDOEDT,1,SDN1)
;
; ** Update the entry in the Patient Appointment multiple for the encounter.
I $D(^DPT(SDFN,"S",SDOEDT,0)),($P(^(0),U,20)=SDOE) D
. S DIE="^DPT(SDFN,""S"",",DA(1)=SDFN,DA=SDOEDT
. S DR="9.5////"_$P(SCELP,U,3)
. L +^DPT(SDFN,"S",SDOEDT):$S($G(DILOCKTM)>0:DILOCKTM,1:5) ;SD*560 added required timeout
. D ^DIE K DIE,DR,DA
. L -^DPT(SDFN,"S",SDOEDT)
;
Q
;
ONEELIG() ;
;tests for and returns the primary if that is the only eligibility
;
N VAEL
D ELIG^VADPT
Q $S($O(VAEL(1,0)):0,1:VAEL(1))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCENIA2 10718 printed Sep 23, 2025@20:16:09 Page 2
SCENIA2 ;ALB/SCK - INCOMPLETE ENCOUNTER ERROR DISPLAY PROTOCOLS, CONT. ; OCT 21, 1998
+1 ;;5.3;Scheduling;**66,132,158,560**;AUG 13, 1993;Build 8
+2 ;
EVT1(SDXMT,INF) ; Returns ifn for ^SC(clinic,"S",date,1,ifn)
+1 NEW SINDX,SDDA
+2 ;
+3 SET SINDX=0
FOR
SET SINDX=$ORDER(^SC(INF("CLINIC"),"S",INF("ENCOUNTER"),1,SINDX))
if 'SINDX>0
QUIT
Begin DoDot:1
+4 IF +^SC(INF("CLINIC"),"S",INF("ENCOUNTER"),1,SINDX,0)=INF("DFN")
SET SDDA=SINDX
End DoDot:1
if $DATA(SDDA)
QUIT
+5 QUIT $GET(SDDA)
+6 ;
EI ; Entry point for the SCENI ENCOUNTER INFORMATION protocol
+1 ; Called via LM.
IF '$DATA(SD53P158)
NEW SD53P158
SET SD53P158="LM"
+2 IF '$DATA(^XUSEC("SCENI ENCOUNTER EDIT",DUZ))
Begin DoDot:1
+3 WRITE !,$CHAR(7),"You do not have this security key, contact your supervisor."
End DoDot:1
QUIT
+4 ;
+5 NEW SDATA,SCEN,SDXMT,SCXER,SDOE,SCINF,SCSTAT,SDEVT,SDHDL,SDDA,SCELAP,SCSTPLC,OLDSC,SDQUIT,SDLOG
+6 ;SD*560
NEW SDFLAG,SDVST
SET SDFLAG=0
SET SDVST=""
+7 ;
+8 KILL PARENT,VISIT
+9 DO HDLKILL^SDAMEVT
+10 SET SDXMT=$GET(^TMP("SCENI XMT",$JOB,0))
if 'SDXMT
QUIT
+11 SET SCSTAT=$$OPENC^SCUTIE1(SDXMT,"SCINF")
+12 IF SCSTAT<0
Begin DoDot:1
+13 WRITE !!,$CHAR(7),"Entry "_$PIECE(^SD(409.73,SDXMT,0),U),?5,$GET(SCINF("ERROR"))
+14 DO PAUSE^VALM1
End DoDot:1
GOTO EIQ
+15 ;
+16 IF SCSTAT>0
Begin DoDot:1
+17 WRITE !!,$CHAR(7),"This is a deleted entry. Encounter information cannot be changed."
+18 DO PAUSE^VALM1
End DoDot:1
GOTO EIQ
+19 ;
+20 SET DFN=SCINF("DFN")
+21 SET SDOE=$PIECE(^SD(409.73,SDXMT,0),U,2)
+22 SET SDHDL=$$HANDLE^SDAMEVT($PIECE($GET(^SCE(SDOE,0)),U,8))
SET SDDA=$$EVT1(SDXMT,.SCINF)
+23 if SDHDL']""
QUIT
+24 ;
+25 ;SD*5.3*560 encounter not associated w/sched appt
if 'SDDA
SET SDFLAG=1
+26 SET SDATA=SDDA_"^"_DFN_"^"_SCINF("ENCOUNTER")_"^"_SCINF("CLINIC")
+27 SET SDQUIT=0
+28 ;
+29 LOCK +^SCE(SDOE):0
IF '$TEST
Begin DoDot:1
+30 WRITE !?5,$CHAR(7),"Another user is editing this entry"
End DoDot:1
GOTO EIQ
+31 IF SD53P158="LM"
DO FULL^VALM1
+32 KILL DIRUT
+33 WRITE !
+34 DO BEFORE^SDAMEVT(.SDATA,DFN,SCINF("ENCOUNTER"),SCINF("CLINIC"),SDDA,SDHDL)
+35 ;
+36 KILL OLDSC,SDEDT
SET OLDSC=+$PIECE($GET(^SCE(SDOE,0)),U,3)
SET SDEDT=$PIECE(^(0),U,1)
EI1 SET DIR(0)="409.68,.03"
SET DA=SDOE
+1 DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y="")
GOTO EIQ
+2 ;SD*560 do not allow if Inactive at time of encounter
+3 IF $PIECE(^DIC(40.7,+Y,0),U,3)'=""
IF $PIECE(^(0),U,3)'>SDEDT
Begin DoDot:1
+4 WRITE !!,"Sorry, that Stop Code was INACTIVE at the time of the selected encounter.",!
End DoDot:1
GOTO EI1
+5 ;SD*560 do not allow if Restriction Type is "S"
+6 IF $PIECE(^DIC(40.7,+Y,0),U,6)="S"
IF $PIECE(^(0),U,7)'>SDEDT
Begin DoDot:1
+7 WRITE !!,"Sorry, the Restriction Type for that Stop Code is 'S' (secondary only).",!,"You cannot select this stop code.",!
End DoDot:1
GOTO EI1
+8 SET $PIECE(SCSTPLC,U)=+Y
+9 DO SET(+Y,.03,SDOE)
+10 ;SD*560 set Visit & Trans flag
IF SDFLAG
IF OLDSC'=+Y
DO SET1(+Y,SDOE,1)
+11 ;
+12 ;SD*560 get current Division
KILL OLDDV
SET OLDDV=+$PIECE($GET(^SCE(SDOE,0)),U,11)
+13 SET DIR(0)="409.68,.11"
SET DA=SDOE
+14 DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y="")
GOTO A1
+15 SET $PIECE(SCSTPLC,U,2)=+Y
+16 DO SET(+Y,.11,SDOE)
+17 ;SD*560 set Visit & Trans flag
IF OLDDV'=+Y
DO SETDV(+Y,SDOE)
+18 KILL OLDDV
+19 ;
+20 ; ** Display current Appt. Type and Elig. Codes
+21 ;SD*560 add OLDAT
NEW SD1,OLDAT
SET (SD1,OLDAT)=$PIECE($GET(^SCE(SDOE,0)),U,10)
+22 WRITE !!!,$CHAR(7),"Current Appointment Type for Encounter: "_$SELECT($GET(SD1):$PIECE(^SD(409.1,SD1,0),U),1:"")
+23 ;sD*560 add OLDELG
KILL SD1,OLDELG
SET (SD1,OLDELG)=$PIECE($GET(^SCE(SDOE,0)),U,13)
+24 WRITE !,"Current Eligibility for Encounter: "_$SELECT($GET(SD1):$PIECE(^DIC(8,SD1,0),U),1:""),!
+25 ;
+26 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Change Eligibility/Appointment type? "
DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y=0)
GOTO A1
+27 ;
+28 ;SD*560 if SC Indicator in Visit equals 1 (Service Connected) do not allow edit of Appt Type or Eligibility
+29 IF $PIECE(^SCE(SDOE,0),U,10)'=10
SET SDVST=$PIECE(^SCE(SDOE,0),U,5)
IF $DATA(^AUPNVSIT(SDVST,800))
IF +$GET(^(800))=1
Begin DoDot:1
+30 WRITE !!,"The Visit associated with the selected encounter is SERVICE CONNECTED."
+31 WRITE !,"You cannot edit the Appointment Type or Eligibility for this encounter.",!
End DoDot:1
GOTO A1
+32 ;
+33 WRITE !,"The following are system defaults only.",!
+34 ;
+35 SET SCELAP=$$ELAP^SDPCE(DFN,SCINF("CLINIC"))
+36 ;
+37 NEW SDPRIM
+38 SET SDPRIM=$$ONEELIG
+39 ;if only a primary ask if they want to change to it and change
+40 IF SDPRIM
IF +SDPRIM'=SD1
Begin DoDot:1
+41 NEW DIR
+42 SET DIR(0)="YA"
SET DIR("B")="YES"
+43 SET DIR("A",1)="There is only a primary eligibility for this patient: "_$PIECE(SDPRIM,U,2)
+44 SET DIR("A")="Do you wish to change the encounter to this? "
+45 SET DIR("?")="No other Eligibilities are selectable."
+46 SET DIR("?",1)="YES will result in the current primary Eligibility being used for the encounter."
+47 SET DIR("?",2)="NO will result in the encounter's Eligibility being left the same."
+48 DO ^DIR
+49 IF Y=1
SET $PIECE(SCELAP,U,1)=+SDPRIM
SET $PIECE(SCELAP,U,2)=$PIECE(SDPRIM,U,2)
+50 IF '$TEST
SET $PIECE(SCELAP,U,1)=SD1
SET $PIECE(SCELAP,U,2)=$PIECE($GET(^DIC(8,+SD1,0)),U,1)
+51 QUIT
End DoDot:1
+52 ;
+53 DO SET(+SCELAP,.13,SDOE)
+54 ;SD*560 if Elig edited on non-appt encounter, update Visit & Trans flag
+55 IF SDFLAG
IF OLDELG'=+SCELAP
DO SET1(+SCELAP,SDOE,2)
+56 DO SET(+$PIECE(SCELAP,U,3),.1,SDOE)
+57 ;
A1 DO RESYNC(SCSTPLC,$GET(SCELAP),SDOE,OLDSC,DFN)
+1 DO LOGDATA^SDAPIAP(SDOE,.SDLOG)
+2 DO AFTER^SDAMEVT(.SDATA,DFN,SCINF("ENCOUNTER"),SCINF("CLINIC"),SDDA,SDHDL)
+3 ;
+4 DO EVT^SDAMEVT(.SDATA,5,0,SDHDL)
+5 IF '$DATA(SDOK)
Begin DoDot:1
+6 SET RTN=$$VALIDATE^SCMSVUT2(SDXMT)
+7 IF RTN<0
DO ERMSG^SCENIA1(5)
QUIT
+8 SET RTN=$$SETRFLG^SCENIA1(SDXMT)
+9 IF RTN<0
DO ERMSG^SCENIA1(3)
QUIT
End DoDot:1
IF $GET(RTN)<0
GOTO EIQ
+10 ;SD*560 if appt type edited, check if it was allowed and changed
+11 IF $DATA(SCELAP)
IF OLDAT'=+$PIECE(SCELAP,U,3)
SET POP=0
Begin DoDot:1
+12 IF OLDAT=10
IF +$PIECE(SCELAP,U,3)=11
Begin DoDot:2
+13 IF +$PIECE(^SCE(SDOE,0),U,10)'=11
IF $DATA(^AUPNVSIT($PIECE(^SCE(SDOE,0),U,5),800))
IF +$GET(^(800),"")=0
DO A1WRT
DO A2WRT
SET POP=1
QUIT
End DoDot:2
if POP
QUIT
+14 IF OLDAT=10
IF +$PIECE(SCELAP,U,3)'=11
Begin DoDot:2
+15 IF +$PIECE(^SCE(SDOE,0),U,10)=11
IF $DATA(^AUPNVSIT($PIECE(^SCE(SDOE,0),U,5),800))
IF +$GET(^(800),"")=1
DO A1WRT1
DO A2WRT
SET POP=1
QUIT
End DoDot:2
if POP
QUIT
+16 if OLDAT'=$PIECE(^SCE(SDOE,0),U,10)
QUIT
+17 IF OLDAT'=11
IF $PIECE(SCELAP,U,3)=11
DO A1WRT
QUIT
End DoDot:1
+18 KILL POP
+19 ;SD*560 if Appt Type edit accepted on non-appt encounter set encounter to retrans
+20 IF SDFLAG
IF $DATA(SCELAP)
IF OLDAT'=+$PIECE(SCELAP,U,3)
Begin DoDot:1
+21 ;get IEN for file 409.73
SET XMIT=""
SET XMIT=$$FINDXMIT^SCDXFU01(SDOE)
+22 ;set trans event to edit
if XMIT
DO STREEVNT^SCDXFU01(XMIT,2)
+23 ;set flag for trans to Yes
if XMIT
DO XMITFLAG^SCDXFU01(XMIT)
+24 KILL XMIT,OLDAT
End DoDot:1
+25 IF $DATA(SDOK)
SET SDOK=1
+26 ;SD*560 moved from RESYNC
WRITE !,"Updating Completed."
+27 LOCK -^SCE(SDOE):0
EIQ KILL OLDSC,OLDAT,OLDELG,SDFLAG
if $DATA(POP)
KILL POP
+1 QUIT
+2 ;
A1WRT ;SD*560 write warning message, if applicable
+1 WRITE !!,"The Visit entry associated with the selected encounter is NOT SERVICE CONNECTED."
+2 WRITE !,"You cannot change the Appointment Type to SERVICE CONNECTED.",!
+3 QUIT
+4 ;
A1WRT1 ;SD*560 write warning message if Service Connected
+1 WRITE !!,"The Visit entry associated with the selected encounter is SERVICE CONNECTED."
+2 WRITE !,"You cannot change the Appointment Type to non-SERVICE CONNECTED."
+3 QUIT
+4 ;
A2WRT ;SD*560 display current Appointment Type per update.
+1 WRITE !,"Appointment Type has been updated to ",$PIECE(^SD(409.1,$PIECE(^SCE(SDOE,0),U,10),0),U,1),".",!
+2 QUIT
+3 ;
SET(SDVAL,SDFLD,DA) ; Set updated entry into file #409.68.
+1 ;
+2 SET ^TMP("SCENI EDIN",$JOB,409.68,DA_",",SDFLD)=SDVAL
+3 DO FILE^DIE("K","^TMP(""SCENI EDIN"",$J)")
+4 IF $DATA(^TMP("DIERR",$JOB,1))
WRITE !!,"???"
+5 KILL ^TMP("SCENI EDIN",$JOB),^TMP("DIERR",$JOB)
+6 QUIT
+7 ;
SET1(SDVAL,SDOE,SEDT) ;SD*560 set Visit & Trans Flag for non-appt encounter
+1 ;SEDT=1 primary stop code edit
+2 ;SEDT=2 eligibility edit
+3 NEW SDVST,VDT,SDCVST
+4 SET SDVST=$PIECE(^SCE(SDOE,0),U,5)
if 'SDVST
QUIT
+5 SET VDT=$$NOW^XLFDT
+6 SET DA=SDVST
SET DIE="^AUPNVSIT("
+7 IF SEDT=1
SET DR=".08////^S X=SDVAL;.13////^S X=VDT"
DO ^DIE
+8 IF SEDT=2
SET DR=".21////^S X=SDVAL;.13////^S X=VDT"
DO ^DIE
+9 ;check for credit Visit and update, if applicable
+10 IF $ORDER(^AUPNVSIT("AD",SDVST,""))
SET SDCVST=$ORDER(^AUPNVSIT("AD",SDVST,""))
Begin DoDot:1
+11 ;do not update if primary stop code edit
if SEDT=1
QUIT
+12 KILL DA,DR
+13 SET DA=SDCVST
+14 SET DR=".21////^S X=SDVAL;.13////^S X=VDT"
DO ^DIE
End DoDot:1
+15 ;get IEN for file 409.73
SET XMIT=""
SET XMIT=$$FINDXMIT^SCDXFU01(SDOE)
+16 ;set trans event to edit
if XMIT
DO STREEVNT^SCDXFU01(XMIT,2)
+17 ;set flag for trans required to Yes
if XMIT
DO XMITFLAG^SCDXFU01(XMIT)
+18 KILL XMIT,DA,DR,X,DIE
+19 QUIT
+20 ;
SETDV(SDVAL,SDOE) ;SD*560 set Visit & Trans Flag when Division edited
+1 NEW SDVST,VDT,SDNDV,SDCVST
+2 SET SDVST=$PIECE(^SCE(SDOE,0),U,5)
if 'SDVST
QUIT
+3 ;get pointer to Institution file
SET SDNDV=+$PIECE($GET(^DG(40.8,SDVAL,0)),U,7)
+4 SET VDT=$$NOW^XLFDT
+5 SET DA=SDVST
SET DIE="^AUPNVSIT("
+6 SET DR=".06////^S X=SDNDV;.13////^S X=VDT"
DO ^DIE
+7 ;check for credit Visit and update, if applicable
+8 IF $ORDER(^AUPNVSIT("AD",SDVST,""))
SET SDCVST=$ORDER(^AUPNVSIT("AD",SDVST,""))
Begin DoDot:1
+9 KILL DA,DR
+10 SET DA=SDCVST
+11 SET DR=".06////^S X=SDNDV;.13////^S X=VDT"
DO ^DIE
End DoDot:1
+12 ;get IEN for file 409.73
SET XMIT=""
SET XMIT=$$FINDXMIT^SCDXFU01(SDOE)
+13 ;set trans event to edit
if XMIT
DO STREEVNT^SCDXFU01(XMIT,2)
+14 ;set flag for trans required to Yes
if XMIT
DO XMITFLAG^SCDXFU01(XMIT)
+15 KILL DA,DR,DIE,SD408,XMIT
+16 QUIT
+17 ;
UPDENC ; Update Outpatient Encounter Option entry point
+1 NEW SDOE,SDXMT,DFN,SDOK
+2 ;Entered via menu option.
NEW SD53P158
SET SD53P158="OPT"
+3 ;
+4 SET SDOK=0
+5 KILL ^TMP("SCENI XMT",$JOB)
+6 SET DIR(0)="PA^409.68:EMQ"
SET DIR("S")="I $D(^SD(409.73,""AENC"",Y))"
+7 SET DIR("A")="Select Encounter to update: "
+8 SET DIR("?")="Enter partial name, last four, or date of encounter."
+9 SET DIR("??")="^S %DT=""PX"" D HELP^%DTC"
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO UPDQ
+11 ;
+12 SET SDOE=+Y
+13 SET SDXMT=$ORDER(^SD(409.73,"AENC",SDOE,0))
+14 SET ^TMP("SCENI XMT",$JOB,0)=SDXMT
+15 DO EI
UPDQ ;
+1 KILL DFN
+2 QUIT
+3 ;
RESYNC(STPL,SCELP,SDOE,SCOLD,SDFN) ;
+1 NEW SDOEC,SDCDT
+2 ;
+3 ; ** Update any child encounters and for each child encounter, search for
+4 ; any entries in the Scheduling Visits File, #409.5. If there is a
+5 ; match, update then entry in #409.5
+6 ;
+7 ;everthing else
+8 SET SDOEC=""
+9 FOR
SET SDOEC=$ORDER(^SCE("APAR",SDOE,SDOEC))
if 'SDOEC
QUIT
Begin DoDot:1
+10 IF +$PIECE($GET(^SCE(SDOE,0)),U,13)>0
DO SET(+$PIECE($GET(^SCE(SDOE,0)),U,13),.13,SDOEC)
+11 IF +$PIECE($GET(^SCE(SDOE,0)),U,10)>0
DO SET(+$PIECE($GET(^SCE(SDOE,0)),U,10),.1,SDOEC)
+12 IF +$PIECE($GET(^SCE(SDOE,0)),U,11)>0
DO SET(+$PIECE($GET(^SCE(SDOE,0)),U,11),.11,SDOEC)
+13 IF "2"[+$PIECE($GET(^SCE(SDOEC,0)),U,8)
IF ($PIECE($GET(^SCE(SDOEC,0)),U,3)=SCOLD)
DO SET(+$PIECE($GET(^SCE(SDOE,0)),U,3),.03,SDOEC)
End DoDot:1
+14 ;
+15 ; ** Update the entry in the Clinic Appointment multiple for the encounter
+16 SET SDOEDT=$PIECE($GET(^SCE(SDOE,0)),U)
SET SDCLN=$PIECE($GET(^(0)),U,4)
+17 SET SDN1=0
FOR
SET SDN1=$ORDER(^SC(SDCLN,"S",SDOEDT,1,SDN1))
if 'SDN1
QUIT
Begin DoDot:1
+18 IF $PIECE($GET(^SC(SDCLN,"S",SDOEDT,1,SDN1,0)),U)=SDFN
Begin DoDot:2
+19 SET DIE="^SC(SDCLN,""S"",SDOEDT,1,"
SET DA(2)=SDCLN
SET DA(1)=SDOEDT
SET DA=SDN1
+20 SET DR="30////"_$PIECE(SCELP,U)
+21 ;SD*560 added required timeout
LOCK +^SC(SDCLN,"S",SDOEDT,1,SDN1):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+22 DO ^DIE
KILL DIE,DR,DA
+23 LOCK -^SC(SDCLN,"S",SDOEDT,1,SDN1)
End DoDot:2
End DoDot:1
+24 ;
+25 ; ** Update the entry in the Patient Appointment multiple for the encounter.
+26 IF $DATA(^DPT(SDFN,"S",SDOEDT,0))
IF ($PIECE(^(0),U,20)=SDOE)
Begin DoDot:1
+27 SET DIE="^DPT(SDFN,""S"","
SET DA(1)=SDFN
SET DA=SDOEDT
+28 SET DR="9.5////"_$PIECE(SCELP,U,3)
+29 ;SD*560 added required timeout
LOCK +^DPT(SDFN,"S",SDOEDT):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+30 DO ^DIE
KILL DIE,DR,DA
+31 LOCK -^DPT(SDFN,"S",SDOEDT)
End DoDot:1
+32 ;
+33 QUIT
+34 ;
ONEELIG() ;
+1 ;tests for and returns the primary if that is the only eligibility
+2 ;
+3 NEW VAEL
+4 DO ELIG^VADPT
+5 QUIT $SELECT($ORDER(VAEL(1,0)):0,1:VAEL(1))
+6 ;
