PXCEVSIT ;slc/dee,ISA/KWP-Used in editing a visit ; 1/7/02 11:36am
;;1.0;PCE PATIENT CARE ENCOUNTER;**9,23,70,116,147,151**;Aug 12, 1996
Q
;
;********************************
;
;Functions
;
ELIGIBIL(PATIENT,HOSPLOC,DATETIME) ;+Eligibility from appointment if there is one.
Q:$G(PATIENT)'>0 -1
Q:$G(HOSPLOC)'>0 -1
Q:$G(DATETIME)'>1600000 -1
Q:'($D(^SC(HOSPLOC,"S",DATETIME,1))\10) -1
N PXCEELIG,PXCEINDX
S PXCEELIG=-1
S PXCEINDX=0
F S PXCEINDX=$O(^SC(HOSPLOC,"S",DATETIME,1,PXCEINDX)) Q:PXCEINDX="" I $P($G(^SC(HOSPLOC,"S",DATETIME,1,PXCEINDX,0)),"^",1)=PATIENT S PXCEELIG=$S($P(^(0),"^",10)>0:$P(^(0),"^",10),1:-1) Q
Q PXCEELIG
;
;********************************
;Special cases for edit of the visit.
;
EVISITDT(REQTIME,DEFAULT) ;
;+REQTIME is 1 if time is required,
;+ 0 if time is optional
;+ -1 if the date can be imprecise
;+DEFAULT is the default date/time is there is not one in the file.
;+ If it is -1 then NOW will be used as the default.
;+ If it is 0 then TODAY will be used as the default.
N PXLIMDT
S PXLIMDT=$S(PXCECAT="HIST":0,1:$$SWITCHD^PXAPI)
S DIR(0)="DO^"_$S(PXLIMDT>2960000:PXLIMDT,1:"")_":"_(DT+.24)_":ESP"
I $G(REQTIME)=1 S DIR(0)=DIR(0)_"RX"
E I $G(REQTIME)=-1 S DIR(0)=DIR(0)_"T"
E S DIR(0)=DIR(0)_"TX"
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" S DIR("B")=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
E I ($D(DEFAULT)#2) D
. N %H,%I,%
. I DEFAULT>0 S DIR("B")=DEFAULT
. E I DEFAULT=0 S DIR("B")=DT
. E I DEFAULT=-1 D NOW^%DTC S DIR("B")=%
I $D(DIR("B"))#2 S Y=DIR("B") D DD^%DT S DIR("B")=Y
S DIR("A")=$P(PXCETEXT,"~",4)
S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
D ^DIR
I '$D(DIRUT),'$D(DUOUT),+VADM(6),$P(Y,".")>+VADM(6) S (DIRUT,DUOUT)=1 W VADM(7) R Y:10
K DIR,DA
Q
;
;
EHOSPLOC ;
N HLOC,PXRES
I $P(PXCEAFTR(0),"^",22)'="" D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)="PA^44:AEMQ"
S DIR("A")=$P(PXCETEXT,"~",4)
I $P(PXCETEXT,"~",8)]"" S DIR("?")=$P(PXCETEXT,"~",8)
;Only clinics that are not occasion of service
; and are not dispositioning clinics
;S DIR("S")="I $P(^(0),U,3)=""C""&'+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
;Only hospital locations that are not dispositioning clinics
;
;not occasion of service and not dispositioning clinics
;S DIR("S")="I '+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
;Exclude disposition clinics from the above listed condition.
S DIR("S")="I '+$G(^(""OOS""))" ;PX*1*116
D ^DIR
K DIR,DA
I $D(DTOUT)!$D(DUOUT) S (PXCEEND,PXCEQUIT)=1 Q
I +Y'>0,PXCECAT'="HIST" D HELPHLOC W !,$C(7) G EHOSPLOC
S HLOC=$S(+Y>0:+Y,1:"")
I HLOC'="" S PXRES=$$CLNCK^SDUTL2(HLOC,1) I 'PXRES D G EHOSPLOC
.W !,$C(7),?5,"Clinic MUST be corrected before continuing."
S $P(PXCEAFTR(0),"^",22)=HLOC
;
;Get the eligibility and appointment type
; if there is not already an appointment.
; Creating a new visit or will lookup and find an old visit.
I '$$APPOINT^PXUTL1(PXCEPAT,+PXCEAFTR(0),HLOC) D
. S PXELAP=$$ELAP^SDPCE($P(PXCEAFTR(0),"^",5),$P(PXCEAFTR(0),"^",22))
E I HLOC>0 D
. ;Get the ELIGIBILITY for the appointment if there is one.
. N PXCEELIG
. S PXCEELIG=$$ELIGIBIL(PXCEPAT,HLOC,$P(PXCEAFTR(0),"^",1))
. S:PXCEELIG>0 $P(PXCEAFTR(0),"^",21)=PXCEELIG
Q
;
HELPDISP ;
W !,"You can not select a Dispositioning Clinic."
Q
;
HELPHLOC ;
W !!,"Enter the name of the Clinic for this Encounter."
W !,"Hospital Location is required."
Q
;
EWORKLOD(ASK) ;
;+If ASK=0 do not ask default to the one for the Hospital Location
N DIC,DA
EWORKLD2 ;
K DTOUT,DUOUT,DIC,DA
I $P(PXCEAFTR(0),"^",8)+$P(PXCEAFTR(0),"^",22) D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. I $P(PXCEAFTR(0),"^",8)'="" S PXCEINT=$P(PXCEAFTR(0),"^",8)
. E S PXCEINT=$P(^SC($P(PXCEAFTR(0),"^",22),0),"^",7)
. S Y=+PXCEINT
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIC("B")=$S('$D(DIERR):PXCEEXT,1:$P(PXCEAFTR(0),"^",8))
S DIC="^DIC(40.7,"
S DIC(0)="AEM"
S DIC("S")="I $P(^(0),U,3)=""""!($P(^(0),U,3)'<$P(PXCEAFTR(0),U))"
S DIC("A")=$P(PXCETEXT,"~",4)
I Y'>0!ASK D
. D ^DIC
K DIR,DA
I $D(DTOUT)!$D(DUOUT) S (PXCEEND,PXCEQUIT)=1 Q
I +Y'>0,PXCECAT'="HIST" G EWORKLD2
;+set the stop code into the visit file
S $P(PXCEAFTR(0),"^",8)=$S(+Y>0:+Y,1:"")
N PXHLOC,PXSC
S PXHLOC=$P(PXCEAFTR(0),"^",22)
S PXSC=$P($G(^SC(+PXHLOC,0)),"^",7)
;+if the hospital location is a ward then set the encounter type to a P for primary
I $P($G(^SC(+PXHLOC,0)),"^",3)["W" S $P(PXCEAFTR(150),"^",3)="P" Q
;+if the stop code on file for the hospital location is the stop code entered or if the stop code in the hospital location file is null then set the encounter type to P for primary
I PXSC=+Y!(PXSC=""&PXHLOC) S $P(PXCEAFTR(150),"^",3)="P"
Q
;
ECODT ;Check out date time
N PXCHKOUT
D CHIKOUT^PXBAPI2("",PXCEPAT,+$P(PXCEAFTR(0),"^",22),$P(PXCEAFTR(0),"^",1))
S:PXCHKOUT>0 $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=PXCHKOUT
Q
;
EPAT ;
I $P(PXCEAFTR(0),"^",5)'="" Q
S DIR(0)="9000010,.05A"
S DIR("A")=$P(PXCETEXT,"~",4)
S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
D ^DIR
K DIR,DA
I X="@" S Y="@"
E I $D(DTOUT)!$D(DUOUT) S (PXCEEND,PXCEQUIT)=1 Q ;for visit
S $P(PXCEAFTR(0),"^",5)=$P(Y,"^")
S PXCEPAT=$P(Y,"^") D PATINFO^PXCEPAT(.PXCEPAT) I $D(DTOUT)!$D(DUOUT) S (PXCEEND,PXCEQUIT)=1 ;PX*1*147
Q
;
SKIP ;Just returns used when need a edit routine that does nothing.
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEVSIT 5789 printed Apr 09, 2024@21:34:04 Page 2
PXCEVSIT ;slc/dee,ISA/KWP-Used in editing a visit ; 1/7/02 11:36am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**9,23,70,116,147,151**;Aug 12, 1996
+2 QUIT
+3 ;
+4 ;********************************
+5 ;
+6 ;Functions
+7 ;
ELIGIBIL(PATIENT,HOSPLOC,DATETIME) ;+Eligibility from appointment if there is one.
+1 if $GET(PATIENT)'>0
QUIT -1
+2 if $GET(HOSPLOC)'>0
QUIT -1
+3 if $GET(DATETIME)'>1600000
QUIT -1
+4 if '($DATA(^SC(HOSPLOC,"S",DATETIME,1))\10)
QUIT -1
+5 NEW PXCEELIG,PXCEINDX
+6 SET PXCEELIG=-1
+7 SET PXCEINDX=0
+8 FOR
SET PXCEINDX=$ORDER(^SC(HOSPLOC,"S",DATETIME,1,PXCEINDX))
if PXCEINDX=""
QUIT
IF $PIECE($GET(^SC(HOSPLOC,"S",DATETIME,1,PXCEINDX,0)),"^",1)=PATIENT
SET PXCEELIG=$SELECT($PIECE(^(0),"^",10)>0:$PIECE(^(0),"^",10),1:-1)
QUIT
+9 QUIT PXCEELIG
+10 ;
+11 ;********************************
+12 ;Special cases for edit of the visit.
+13 ;
EVISITDT(REQTIME,DEFAULT) ;
+1 ;+REQTIME is 1 if time is required,
+2 ;+ 0 if time is optional
+3 ;+ -1 if the date can be imprecise
+4 ;+DEFAULT is the default date/time is there is not one in the file.
+5 ;+ If it is -1 then NOW will be used as the default.
+6 ;+ If it is 0 then TODAY will be used as the default.
+7 NEW PXLIMDT
+8 SET PXLIMDT=$SELECT(PXCECAT="HIST":0,1:$$SWITCHD^PXAPI)
+9 SET DIR(0)="DO^"_$SELECT(PXLIMDT>2960000:PXLIMDT,1:"")_":"_(DT+.24)_":ESP"
+10 IF $GET(REQTIME)=1
SET DIR(0)=DIR(0)_"RX"
+11 IF '$TEST
IF $GET(REQTIME)=-1
SET DIR(0)=DIR(0)_"T"
+12 IF '$TEST
SET DIR(0)=DIR(0)_"TX"
+13 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
SET DIR("B")=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+14 IF '$TEST
IF ($DATA(DEFAULT)#2)
Begin DoDot:1
+15 NEW %H,%I,%
+16 IF DEFAULT>0
SET DIR("B")=DEFAULT
+17 IF '$TEST
IF DEFAULT=0
SET DIR("B")=DT
+18 IF '$TEST
IF DEFAULT=-1
DO NOW^%DTC
SET DIR("B")=%
End DoDot:1
+19 IF $DATA(DIR("B"))#2
SET Y=DIR("B")
DO DD^%DT
SET DIR("B")=Y
+20 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+21 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+22 DO ^DIR
+23 IF '$DATA(DIRUT)
IF '$DATA(DUOUT)
IF +VADM(6)
IF $PIECE(Y,".")>+VADM(6)
SET (DIRUT,DUOUT)=1
WRITE VADM(7)
READ Y:10
+24 KILL DIR,DA
+25 QUIT
+26 ;
+27 ;
EHOSPLOC ;
+1 NEW HLOC,PXRES
+2 IF $PIECE(PXCEAFTR(0),"^",22)'=""
Begin DoDot:1
+3 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+4 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+5 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+6 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+7 SET DIR(0)="PA^44:AEMQ"
+8 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+9 IF $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+10 ;Only clinics that are not occasion of service
+11 ; and are not dispositioning clinics
+12 ;S DIR("S")="I $P(^(0),U,3)=""C""&'+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
+13 ;Only hospital locations that are not dispositioning clinics
+14 ;
+15 ;not occasion of service and not dispositioning clinics
+16 ;S DIR("S")="I '+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
+17 ;Exclude disposition clinics from the above listed condition.
+18 ;PX*1*116
SET DIR("S")="I '+$G(^(""OOS""))"
+19 DO ^DIR
+20 KILL DIR,DA
+21 IF $DATA(DTOUT)!$DATA(DUOUT)
SET (PXCEEND,PXCEQUIT)=1
QUIT
+22 IF +Y'>0
IF PXCECAT'="HIST"
DO HELPHLOC
WRITE !,$CHAR(7)
GOTO EHOSPLOC
+23 SET HLOC=$SELECT(+Y>0:+Y,1:"")
+24 IF HLOC'=""
SET PXRES=$$CLNCK^SDUTL2(HLOC,1)
IF 'PXRES
Begin DoDot:1
+25 WRITE !,$CHAR(7),?5,"Clinic MUST be corrected before continuing."
End DoDot:1
GOTO EHOSPLOC
+26 SET $PIECE(PXCEAFTR(0),"^",22)=HLOC
+27 ;
+28 ;Get the eligibility and appointment type
+29 ; if there is not already an appointment.
+30 ; Creating a new visit or will lookup and find an old visit.
+31 IF '$$APPOINT^PXUTL1(PXCEPAT,+PXCEAFTR(0),HLOC)
Begin DoDot:1
+32 SET PXELAP=$$ELAP^SDPCE($PIECE(PXCEAFTR(0),"^",5),$PIECE(PXCEAFTR(0),"^",22))
End DoDot:1
+33 IF '$TEST
IF HLOC>0
Begin DoDot:1
+34 ;Get the ELIGIBILITY for the appointment if there is one.
+35 NEW PXCEELIG
+36 SET PXCEELIG=$$ELIGIBIL(PXCEPAT,HLOC,$PIECE(PXCEAFTR(0),"^",1))
+37 if PXCEELIG>0
SET $PIECE(PXCEAFTR(0),"^",21)=PXCEELIG
End DoDot:1
+38 QUIT
+39 ;
HELPDISP ;
+1 WRITE !,"You can not select a Dispositioning Clinic."
+2 QUIT
+3 ;
HELPHLOC ;
+1 WRITE !!,"Enter the name of the Clinic for this Encounter."
+2 WRITE !,"Hospital Location is required."
+3 QUIT
+4 ;
EWORKLOD(ASK) ;
+1 ;+If ASK=0 do not ask default to the one for the Hospital Location
+2 NEW DIC,DA
EWORKLD2 ;
+1 KILL DTOUT,DUOUT,DIC,DA
+2 IF $PIECE(PXCEAFTR(0),"^",8)+$PIECE(PXCEAFTR(0),"^",22)
Begin DoDot:1
+3 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+4 IF $PIECE(PXCEAFTR(0),"^",8)'=""
SET PXCEINT=$PIECE(PXCEAFTR(0),"^",8)
+5 IF '$TEST
SET PXCEINT=$PIECE(^SC($PIECE(PXCEAFTR(0),"^",22),0),"^",7)
+6 SET Y=+PXCEINT
+7 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+8 SET DIC("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:$PIECE(PXCEAFTR(0),"^",8))
End DoDot:1
+9 SET DIC="^DIC(40.7,"
+10 SET DIC(0)="AEM"
+11 SET DIC("S")="I $P(^(0),U,3)=""""!($P(^(0),U,3)'<$P(PXCEAFTR(0),U))"
+12 SET DIC("A")=$PIECE(PXCETEXT,"~",4)
+13 IF Y'>0!ASK
Begin DoDot:1
+14 DO ^DIC
End DoDot:1
+15 KILL DIR,DA
+16 IF $DATA(DTOUT)!$DATA(DUOUT)
SET (PXCEEND,PXCEQUIT)=1
QUIT
+17 IF +Y'>0
IF PXCECAT'="HIST"
GOTO EWORKLD2
+18 ;+set the stop code into the visit file
+19 SET $PIECE(PXCEAFTR(0),"^",8)=$SELECT(+Y>0:+Y,1:"")
+20 NEW PXHLOC,PXSC
+21 SET PXHLOC=$PIECE(PXCEAFTR(0),"^",22)
+22 SET PXSC=$PIECE($GET(^SC(+PXHLOC,0)),"^",7)
+23 ;+if the hospital location is a ward then set the encounter type to a P for primary
+24 IF $PIECE($GET(^SC(+PXHLOC,0)),"^",3)["W"
SET $PIECE(PXCEAFTR(150),"^",3)="P"
QUIT
+25 ;+if the stop code on file for the hospital location is the stop code entered or if the stop code in the hospital location file is null then set the encounter type to P for primary
+26 IF PXSC=+Y!(PXSC=""&PXHLOC)
SET $PIECE(PXCEAFTR(150),"^",3)="P"
+27 QUIT
+28 ;
ECODT ;Check out date time
+1 NEW PXCHKOUT
+2 DO CHIKOUT^PXBAPI2("",PXCEPAT,+$PIECE(PXCEAFTR(0),"^",22),$PIECE(PXCEAFTR(0),"^",1))
+3 if PXCHKOUT>0
SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=PXCHKOUT
+4 QUIT
+5 ;
EPAT ;
+1 IF $PIECE(PXCEAFTR(0),"^",5)'=""
QUIT
+2 SET DIR(0)="9000010,.05A"
+3 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+4 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+5 DO ^DIR
+6 KILL DIR,DA
+7 IF X="@"
SET Y="@"
+8 ;for visit
IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET (PXCEEND,PXCEQUIT)=1
QUIT
+9 SET $PIECE(PXCEAFTR(0),"^",5)=$PIECE(Y,"^")
+10 ;PX*1*147
SET PXCEPAT=$PIECE(Y,"^")
DO PATINFO^PXCEPAT(.PXCEPAT)
IF $DATA(DTOUT)!$DATA(DUOUT)
SET (PXCEEND,PXCEQUIT)=1
+11 QUIT
+12 ;
SKIP ;Just returns used when need a edit routine that does nothing.
+1 QUIT
+2 ;
