Routine: PXCEVSIT

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

 ;********************************

 ;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

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

HELPDISP ;

 W !,"You can not select a Dispositioning Clinic."

HELPHLOC ;

 W !!,"Enter the name of the Clinic for this Encounter."

 W !,"Hospital Location is required."

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"

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

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

SKIP ;Just returns used when need a edit routine that does nothing.

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEVSIT   5789     printed  Feb 18, 2025@23:54:43                                                                                                                                                                                                    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       ;

PXCEVSIT.m