PXBAPI1 ;ISL/JVS,DEE - PCE's API - interview questions ;05/14/2024 10:01AM
;;1.0;PCE PATIENT CARE ENCOUNTER;**1,9,23,56,104,111,113,122,116,130,147,151,124,164,182,168,211,240**;Aug 12, 1996;Build 55
;;
; Reference to $$ELIG^DGCOMPACTELIG in ICR #7462
Q
;
PROCESS(PXBEXIT) ;
N PXBREQ
I WHAT="INTV" D
. ;-- Interview is all of the questions
. D ADQ(.PXBEXIT) I PXBEXIT<1 Q
1 . D PRV(.PXBEXIT) I PXBEXIT<1 Q
3 . D POV(.PXBEXIT) I PXBEXIT<1 Q
2 . D CPT(.PXBEXIT) I PXBEXIT<1 Q
. I $P($G(^AUPNVSIT($G(PXBVST),150)),"^",3)="O" S PXBEXIT=0 Q
. I '$$DISPOSIT^PXUTL1($G(PXBPAT),$P($G(^AUPNVSIT(PXBVST,0)),"^",1),$G(PXBVST)) D STP(.PXBEXIT) I PXBEXIT<1 Q
E I WHAT="ADDEDIT" D
. D ADDEDIT
E I WHAT="ADQ" D
. ;-- Administrative questions
. D ADQ(.PXBEXIT)
E I WHAT="CODT" D
. ;-- Check out Date/Time
. D CODT(.PXBEXIT)
. Q:PXBEXIT<1
. D VISIT(.PXBEXIT)
. I PXBVST'>0 S PXBEXIT=-2 Q
E I WHAT="SCC" D
. ;-- Service connected conditions
. S PXCECAT="VST" D SCC(.PXBEXIT) K PXCECAT
. Q:PXBEXIT<1
. D VISIT(.PXBEXIT)
. I PXBVST'>0 S PXBEXIT=-2 Q
E I WHAT="PRV" D
. ;-- Providers
. D PRV(.PXBEXIT)
E I WHAT="CPT" D
. ;-- Providers and CPT codes
. D CPT(.PXBEXIT)
E I WHAT="POV" D
. ;-- Diagnoses
. D POV(.PXBEXIT)
E I WHAT="STP" D
. ;-- Stop Codes
. D STP(.PXBEXIT)
E S PXBEXIT=-3 W !,"Procedure ""INTV^PXAPI"" was called incorrectly, contact IRM."
;
;PX*1*240 Set VISIT pointer from checkout interview
I $G(^TMP("PXCOMPACT",$J,"ASC"))=1 D VISIT^PXCOMPACT(PXBVST,"O",$$GETEOC^PXCOMPACT(PXBPAT),PXBPAT)
K ^TMP("PXCOMPACT",$J,"ASC")
Q
;
ADDEDIT ;
N PXANS
ADDEDIT1 ;
D ADQ(.PXBEXIT)
G:PXBEXIT<1 ADDEDIT2
D PRV(.PXBEXIT)
G:PXBEXIT<1 ADDEDIT2
D POV(.PXBEXIT)
G:PXBEXIT<1 ADDEDIT2
;
;Call to CPT is not determined by a credit stop code any more
;
D CPT(.PXBEXIT)
G:PXBEXIT<1 ADDEDIT2
I PXBVST>0,'$D(^AUPNVCPT("AD",PXBVST)) D ADDEDIT3 ;PX*1.0*182
Q ; PX*1.0*182 added quit, otherwise user is forced to delete enc.
;
ADDEDIT2 ;
I PXBVST>0,'$D(^AUPNVCPT("AD",PXBVST)),'$D(^AUPNVSIT("AD",PXBVST)) D I PXANS'=1 S PXBEXIT=1 G ADDEDIT1
. N DIR,X,Y
. W !!
. S DIR(0)="Y"
. S DIR("A",1)="Must have a STOP CODE or a PROCEDURE to complete this action."
. S DIR("A")="Do you want to delete this encounter"
. S DIR("B")="NO"
. D ^DIR
. S PXANS=Y
. Q:PXANS'=1
. I $$DELVFILE^PXAPIDEL("ALL",PXBVST,"","","","","")=1 S PXBEXIT=-1
I PXBVST>0,'$D(^AUPNVSIT(PXBVST,0)) S PXBVST=""
Q
;
ADDEDIT3 ;added PX*1.0*182
N DIR,X,Y
W !!
S DIR(0)="Y"
S DIR("A",1)="Must have a STOP CODE or a PROCEDURE to complete this action."
S DIR("A")="Do you want to delete this encounter"
S DIR("B")="NO"
D ^DIR
Q:Y'=1
I $$DELVFILE^PXAPIDEL("ALL",PXBVST,"","","","","")=1 S PXBVST=""
Q
;
ADQ(PXBEXIT) ;Ask the Administration questions
I PXBVST'>0 D
. ;This is only done for new visits
. I PXBPAT'>0 S PXBPAT=$$ASKPAT I PXBPAT'>0 S PXBEXIT=-1 Q
. I PXBHLOC'>0 S PXBHLOC=$$ASKHL I PXBHLOC'>0 S PXBEXIT=-1 Q
. S PXBVSTDT=$S(PXBAPPT>0:PXBAPPT,1:$$ASKDT) I PXBVSTDT'>0 S PXBEXIT=-1 Q
. I PXBAPPT'>0&PXBHLOC'=+$G(^DPT(PXBPAT,"S",PXBVSTDT,0)) D
.. ;This is only done if there is no appointment.
.. S PXELAP=$$ELAP^SDPCE(PXBPAT,PXBHLOC)
I PXBEXIT'<1,PXBHLOC'>0 S PXBHLOC=$$ASKHL I PXBHLOC'>0 S PXBEXIT=-1 Q
I PXBEXIT'<1 D CODT(.PXBEXIT)
I PXBEXIT'<1,WHAT'="INTV" S PXCECAT="VST" D SCC(.PXBEXIT) K PXCECAT
I PXBEXIT'<1 D
. D VISIT(.PXBEXIT)
. I PXBVST'>0 S PXBEXIT=-2 Q
Q
;
ASKPAT() ;Ask user for a patient
;DIC on file 9000001
N DIR,DIC,Y,X,DA
S DIR(0)="P^9000001:AEMQ"
S DIR("A")="Patient Name"
D ^DIR
Q $S(+Y>0:+Y,1:-1)
;
ASKHL() ;Ask user for a Hospital Location
ASKHL2 ;DIC on file 44
N DIR,DIC,Y,X,DA,PXRES
S DIR(0)="PA^44:AEMQ"
S DIR("A")="Clinic: "
; not occasion of service and not dispositioning
;I PXALHLOC S DIR("S")="I '+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
; not occasion of service only ;PX*1.0*116
I PXALHLOC S DIR("S")="I '+$G(^(""OOS""))" ;PX*1.0*116
; only clinic that are not occasion of service and not dispositioning
;E S DIR("S")="I $P(^(0),U,3)=""C""&'+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
E S DIR("S")="I $P(^(0),U,3)=""C""&'+$G(^(""OOS""))" ;PX*1.0*116
D ^DIR
;enable to select a disposition clinic ;PX*1.0*116
;I $D(^PX(815,1,"DHL","B",+Y)) D HELPDISP^PXCEVSIT W !,$C(7) G ASKHL2
; disallow selection of clinics with non conforming stop codes
I +Y>0 S PXRES=$$CLNCK^SDUTL2(+Y,1) I 'PXRES D G ASKHL2
.W !,?5,"Clinic MUST be corrected before continuing."
Q $S(+Y>0:+Y,1:-1)
;
ASKDT() ;Ask user for the encounter Date/Time
N DIR,Y,X,DA
S DIR(0)="D^"_$S(PXLIMDT>2960000:PXLIMDT,1:"")_":"_(DT+.24)_":AEPRSX"
S DIR("A")="Encounter Date and Time"
S DIR("?")="Enter the Date and Time of this encounter"
D ^DIR
Q $S(+Y>0:+Y,1:-1)
;
CODT(PXBEXIT) ;Ask the user the Check out Date/Time
N DATA,PXCHKOUT
D CHIKOUT^PXBAPI2("",PXBPAT,PXBHLOC,PXBVSTDT)
S PXBCODT=PXCHKOUT
S:PXCHKOUT=-1 PXBCODT=""
;; PX*1*113 - Change for EAS*1*3 Appointment processing removed
;S X="EASMTCHK" X ^%ZOSF("TEST") I $T D Q:PXBEXIT<1
;. S:$G(EASACT)'="W" EASACT="C"
;. I $$MT^EASMTCHK(PXBPAT,"",EASACT,PXBVSTDT) D S PXBEXIT=-1
;. . D PAUSE^VALM1
I WHAT'["ADDEDIT",PXCHKOUT=-1 S PXBEXIT=-1
I $G(PXBVST),$$DISPOSIT^PXUTL1(PXBPAT,$P($G(^AUPNVSIT(PXBVST,0)),"^",1),PXBVST) S PXBEXIT=1
;make call to determine patient eligibility
N ELIG S ELIG=$$ELIG^DGCOMPACTELIG(PXBPAT,"PXBAPI1")
W !!,"COMPACT Act Administrative Eligibility: ",ELIG
I ELIG'="NOT ELIGIBLE" D
. S DATA=$$DISPLAY^PXCOMPACT(PXBPAT)
. I DATA'="" W !,$P(DATA,"^",1),": ",$P(DATA,"^",2)," ",$P(DATA,"^",3),": ",$P(DATA,"^",4)
. K ^TMP("PXCOMPACT",$J,"ASC")
. ;prompt for Treatment Related To Acute Suicidal Crisis
. I $$ASC^PXCOMPACT(PXBPAT)="N" Q
. N DIR,Y,DIRUT
. S DIR("A")="Was treatment for Acute Suicidal Crisis",DIR(0)="Y"
. S DIR("?")="Enter YES if visit is related to an Acute Suicidal Crisis or NO if it is not."
. W ! D ^DIR I $D(DIRUT) S Y=""
. S ^TMP("PXCOMPACT",$J,"ASC")=$G(Y)
;
Q
;
SCC(PXBEXIT) ;Ask the user the Service connected conditions
N PXBDATA,PXBCLASS,PXBOUTEN,PXDOD
S (PXBOUTEN,PXDOD)=""
;I $$APPOINT^PXUTL1(PXBPAT,PXBVSTDT,PXBHLOC) D
;. S PXBOUTEN=$P($G(^DPT(+PXBPAT,"S",+PXBVSTDT,0)),"^",20)
;E I $$DISPOSIT^PXUTL1(PXBPAT,PXBVSTDT,PXBVST) D
;. S PXBOUTEN=+$P($G(^DPT(+PXBPAT,"DIS",9999999-PXBVSTDT,0)),"^",18)
;I 'PXBOUTEN,$G(PXBVST)>0 S PXBOUTEN=$O(^SCE("AVSIT",PXBVST,0))
;D CLASS^PXBAPI21(PXBOUTEN,PXBPAT,PXBVSTDT,PXBHLOC)
D CLASS^PXBAPI21(PXBOUTEN,PXBPAT,PXBVSTDT,PXBHLOC,PXBVST)
;PX*1*111 - Add HNC
F PXBCLASS=1:1:8 I $G(PXBDATA("ERR",PXBCLASS))=4 S PXBEXIT=-1 Q ; changed 6/17/98 for MST enhancement
Q:PXBEXIT<1
I $G(PXDOD) S PXBEXIT=-1 Q
S PXB800(1)=$P($G(PXBDATA(3)),"^",2)
S PXB800(2)=$P($G(PXBDATA(1)),"^",2)
S PXB800(3)=$P($G(PXBDATA(2)),"^",2)
S PXB800(4)=$P($G(PXBDATA(4)),"^",2)
S PXB800(5)=$P($G(PXBDATA(5)),"^",2) ;added 6/17/98 for MST enhancement
;PX*1*111 - Add HNC
S PXB800(6)=$P($G(PXBDATA(6)),"^",2)
S PXB800(7)=$P($G(PXBDATA(7)),"^",2)
S PXB800(8)=$P($G(PXBDATA(8)),"^",2)
Q
;
VISIT(PXBEXIT) ;Create or edit the Visit
;Set up ^TMP("PXK",$J and call PXK
K ^TMP("PXK",$J)
N PXBNODE,PXBAFTER,PXKERROR
F PXBNODE=0,21,150,800,811,812 D
. S PXBAFTER(PXBNODE)=$S(PXBVST>0:$G(^AUPNVSIT(PXBVST,PXBNODE)),1:"")
. S ^TMP("PXK",$J,"VST",1,PXBNODE,"BEFORE")=PXBAFTER(PXBNODE)
I PXBVST'>0 D
. S $P(PXBAFTER(0),"^",1)=PXBVSTDT
. S $P(PXBAFTER(0),"^",5)=PXBPAT
. S $P(PXBAFTER(0),"^",8)=$P(^SC(PXBHLOC,0),"^",7)
. S:PXBAPPT>0 $P(PXBAFTER(0),"^",7)="A" ;PX*1*124
. S $P(PXBAFTER(150),"^",3)="P"
. S $P(PXBAFTER(812),"^",2)=PXBPKG
. S $P(PXBAFTER(812),"^",3)=PXBSOURC
S $P(PXBAFTER(0),"^",18)=$G(PXBCODT)
S:$P(PXBAFTER(0),"^",22)="" $P(PXBAFTER(0),"^",22)=PXBHLOC
S $P(PXBAFTER(800),"^",1)=$G(PXB800(1))
S $P(PXBAFTER(800),"^",2)=$G(PXB800(2))
S $P(PXBAFTER(800),"^",3)=$G(PXB800(3))
S $P(PXBAFTER(800),"^",4)=$G(PXB800(4))
S $P(PXBAFTER(800),"^",5)=$G(PXB800(5)) ;added 6/17/98 for MST enhancement
;PX*1*111 - Add HNC
S $P(PXBAFTER(800),"^",6)=$G(PXB800(6))
S $P(PXBAFTER(800),"^",7)=$G(PXB800(7))
S $P(PXBAFTER(800),"^",8)=$G(PXB800(8))
I $D(PXELAP)#2 D
. S $P(PXBAFTER(0),"^",21)=+PXELAP
F PXBNODE=0,21,150,800,811,812 D
. S ^TMP("PXK",$J,"VST",1,PXBNODE,"AFTER")=PXBAFTER(PXBNODE)
S ^TMP("PXK",$J,"VST",1,"IEN")=$S(PXBVST>0:PXBVST,1:"")
S ^TMP("PXK",$J,"SOR")=PXBSOURC
D EN1^PXKMAIN
S PXBVST=$G(^TMP("PXK",$J,"VST",1,"IEN"))
Q
;
CPT(PXBEXIT) ;Ask the user Providers and CTPs
D CPT^PXBMCPT(PXBVST) K PRVDR
Q
;
POV(PXBEXIT) ;Ask the user Diagnoses
D POV^PXBMPOV(PXBVST) K PRVDR
Q
;
PRV(PXBEXIT) ;Ask the user Providers
D PRV^PXBMPRV(PXBVST,"PRV") K PRVDR
Q
;
STP(PXBEXIT) ;Ask the user Stop Codes
I $L($T(DATE^SCDXUTL)),$$DATE^SCDXUTL(+$G(^AUPNVSIT(PXBVST,0))) Q
D STP^PXBMSTP(PXBVST) K PRVDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBAPI1 9052 printed Nov 22, 2024@17:36:21 Page 2
PXBAPI1 ;ISL/JVS,DEE - PCE's API - interview questions ;05/14/2024 10:01AM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,9,23,56,104,111,113,122,116,130,147,151,124,164,182,168,211,240**;Aug 12, 1996;Build 55
+2 ;;
+3 ; Reference to $$ELIG^DGCOMPACTELIG in ICR #7462
+4 QUIT
+5 ;
PROCESS(PXBEXIT) ;
+1 NEW PXBREQ
+2 IF WHAT="INTV"
Begin DoDot:1
+3 ;-- Interview is all of the questions
+4 DO ADQ(.PXBEXIT)
IF PXBEXIT<1
QUIT
1 DO PRV(.PXBEXIT)
IF PXBEXIT<1
QUIT
3 DO POV(.PXBEXIT)
IF PXBEXIT<1
QUIT
2 DO CPT(.PXBEXIT)
IF PXBEXIT<1
QUIT
+1 IF $PIECE($GET(^AUPNVSIT($GET(PXBVST),150)),"^",3)="O"
SET PXBEXIT=0
QUIT
+2 IF '$$DISPOSIT^PXUTL1($GET(PXBPAT),$PIECE($GET(^AUPNVSIT(PXBVST,0)),"^",1),$GET(PXBVST))
DO STP(.PXBEXIT)
IF PXBEXIT<1
QUIT
End DoDot:1
+3 IF '$TEST
IF WHAT="ADDEDIT"
Begin DoDot:1
+4 DO ADDEDIT
End DoDot:1
+5 IF '$TEST
IF WHAT="ADQ"
Begin DoDot:1
+6 ;-- Administrative questions
+7 DO ADQ(.PXBEXIT)
End DoDot:1
+8 IF '$TEST
IF WHAT="CODT"
Begin DoDot:1
+9 ;-- Check out Date/Time
+10 DO CODT(.PXBEXIT)
+11 if PXBEXIT<1
QUIT
+12 DO VISIT(.PXBEXIT)
+13 IF PXBVST'>0
SET PXBEXIT=-2
QUIT
End DoDot:1
+14 IF '$TEST
IF WHAT="SCC"
Begin DoDot:1
+15 ;-- Service connected conditions
+16 SET PXCECAT="VST"
DO SCC(.PXBEXIT)
KILL PXCECAT
+17 if PXBEXIT<1
QUIT
+18 DO VISIT(.PXBEXIT)
+19 IF PXBVST'>0
SET PXBEXIT=-2
QUIT
End DoDot:1
+20 IF '$TEST
IF WHAT="PRV"
Begin DoDot:1
+21 ;-- Providers
+22 DO PRV(.PXBEXIT)
End DoDot:1
+23 IF '$TEST
IF WHAT="CPT"
Begin DoDot:1
+24 ;-- Providers and CPT codes
+25 DO CPT(.PXBEXIT)
End DoDot:1
+26 IF '$TEST
IF WHAT="POV"
Begin DoDot:1
+27 ;-- Diagnoses
+28 DO POV(.PXBEXIT)
End DoDot:1
+29 IF '$TEST
IF WHAT="STP"
Begin DoDot:1
+30 ;-- Stop Codes
+31 DO STP(.PXBEXIT)
End DoDot:1
+32 IF '$TEST
SET PXBEXIT=-3
WRITE !,"Procedure ""INTV^PXAPI"" was called incorrectly, contact IRM."
+33 ;
+34 ;PX*1*240 Set VISIT pointer from checkout interview
+35 IF $GET(^TMP("PXCOMPACT",$JOB,"ASC"))=1
DO VISIT^PXCOMPACT(PXBVST,"O",$$GETEOC^PXCOMPACT(PXBPAT),PXBPAT)
+36 KILL ^TMP("PXCOMPACT",$JOB,"ASC")
+37 QUIT
+38 ;
ADDEDIT ;
+1 NEW PXANS
ADDEDIT1 ;
+1 DO ADQ(.PXBEXIT)
+2 if PXBEXIT<1
GOTO ADDEDIT2
+3 DO PRV(.PXBEXIT)
+4 if PXBEXIT<1
GOTO ADDEDIT2
+5 DO POV(.PXBEXIT)
+6 if PXBEXIT<1
GOTO ADDEDIT2
+7 ;
+8 ;Call to CPT is not determined by a credit stop code any more
+9 ;
+10 DO CPT(.PXBEXIT)
+11 if PXBEXIT<1
GOTO ADDEDIT2
+12 ;PX*1.0*182
IF PXBVST>0
IF '$DATA(^AUPNVCPT("AD",PXBVST))
DO ADDEDIT3
+13 ; PX*1.0*182 added quit, otherwise user is forced to delete enc.
QUIT
+14 ;
ADDEDIT2 ;
+1 IF PXBVST>0
IF '$DATA(^AUPNVCPT("AD",PXBVST))
IF '$DATA(^AUPNVSIT("AD",PXBVST))
Begin DoDot:1
+2 NEW DIR,X,Y
+3 WRITE !!
+4 SET DIR(0)="Y"
+5 SET DIR("A",1)="Must have a STOP CODE or a PROCEDURE to complete this action."
+6 SET DIR("A")="Do you want to delete this encounter"
+7 SET DIR("B")="NO"
+8 DO ^DIR
+9 SET PXANS=Y
+10 if PXANS'=1
QUIT
+11 IF $$DELVFILE^PXAPIDEL("ALL",PXBVST,"","","","","")=1
SET PXBEXIT=-1
End DoDot:1
IF PXANS'=1
SET PXBEXIT=1
GOTO ADDEDIT1
+12 IF PXBVST>0
IF '$DATA(^AUPNVSIT(PXBVST,0))
SET PXBVST=""
+13 QUIT
+14 ;
ADDEDIT3 ;added PX*1.0*182
+1 NEW DIR,X,Y
+2 WRITE !!
+3 SET DIR(0)="Y"
+4 SET DIR("A",1)="Must have a STOP CODE or a PROCEDURE to complete this action."
+5 SET DIR("A")="Do you want to delete this encounter"
+6 SET DIR("B")="NO"
+7 DO ^DIR
+8 if Y'=1
QUIT
+9 IF $$DELVFILE^PXAPIDEL("ALL",PXBVST,"","","","","")=1
SET PXBVST=""
+10 QUIT
+11 ;
ADQ(PXBEXIT) ;Ask the Administration questions
+1 IF PXBVST'>0
Begin DoDot:1
+2 ;This is only done for new visits
+3 IF PXBPAT'>0
SET PXBPAT=$$ASKPAT
IF PXBPAT'>0
SET PXBEXIT=-1
QUIT
+4 IF PXBHLOC'>0
SET PXBHLOC=$$ASKHL
IF PXBHLOC'>0
SET PXBEXIT=-1
QUIT
+5 SET PXBVSTDT=$SELECT(PXBAPPT>0:PXBAPPT,1:$$ASKDT)
IF PXBVSTDT'>0
SET PXBEXIT=-1
QUIT
+6 IF PXBAPPT'>0&PXBHLOC'=+$GET(^DPT(PXBPAT,"S",PXBVSTDT,0))
Begin DoDot:2
+7 ;This is only done if there is no appointment.
+8 SET PXELAP=$$ELAP^SDPCE(PXBPAT,PXBHLOC)
End DoDot:2
End DoDot:1
+9 IF PXBEXIT'<1
IF PXBHLOC'>0
SET PXBHLOC=$$ASKHL
IF PXBHLOC'>0
SET PXBEXIT=-1
QUIT
+10 IF PXBEXIT'<1
DO CODT(.PXBEXIT)
+11 IF PXBEXIT'<1
IF WHAT'="INTV"
SET PXCECAT="VST"
DO SCC(.PXBEXIT)
KILL PXCECAT
+12 IF PXBEXIT'<1
Begin DoDot:1
+13 DO VISIT(.PXBEXIT)
+14 IF PXBVST'>0
SET PXBEXIT=-2
QUIT
End DoDot:1
+15 QUIT
+16 ;
ASKPAT() ;Ask user for a patient
+1 ;DIC on file 9000001
+2 NEW DIR,DIC,Y,X,DA
+3 SET DIR(0)="P^9000001:AEMQ"
+4 SET DIR("A")="Patient Name"
+5 DO ^DIR
+6 QUIT $SELECT(+Y>0:+Y,1:-1)
+7 ;
ASKHL() ;Ask user for a Hospital Location
ASKHL2 ;DIC on file 44
+1 NEW DIR,DIC,Y,X,DA,PXRES
+2 SET DIR(0)="PA^44:AEMQ"
+3 SET DIR("A")="Clinic: "
+4 ; not occasion of service and not dispositioning
+5 ;I PXALHLOC S DIR("S")="I '+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
+6 ; not occasion of service only ;PX*1.0*116
+7 ;PX*1.0*116
IF PXALHLOC
SET DIR("S")="I '+$G(^(""OOS""))"
+8 ; only clinic that are not occasion of service and not dispositioning
+9 ;E S DIR("S")="I $P(^(0),U,3)=""C""&'+$G(^(""OOS""))&'$O(^PX(815,1,""DHL"",""B"",Y,0))"
+10 ;PX*1.0*116
IF '$TEST
SET DIR("S")="I $P(^(0),U,3)=""C""&'+$G(^(""OOS""))"
+11 DO ^DIR
+12 ;enable to select a disposition clinic ;PX*1.0*116
+13 ;I $D(^PX(815,1,"DHL","B",+Y)) D HELPDISP^PXCEVSIT W !,$C(7) G ASKHL2
+14 ; disallow selection of clinics with non conforming stop codes
+15 IF +Y>0
SET PXRES=$$CLNCK^SDUTL2(+Y,1)
IF 'PXRES
Begin DoDot:1
+16 WRITE !,?5,"Clinic MUST be corrected before continuing."
End DoDot:1
GOTO ASKHL2
+17 QUIT $SELECT(+Y>0:+Y,1:-1)
+18 ;
ASKDT() ;Ask user for the encounter Date/Time
+1 NEW DIR,Y,X,DA
+2 SET DIR(0)="D^"_$SELECT(PXLIMDT>2960000:PXLIMDT,1:"")_":"_(DT+.24)_":AEPRSX"
+3 SET DIR("A")="Encounter Date and Time"
+4 SET DIR("?")="Enter the Date and Time of this encounter"
+5 DO ^DIR
+6 QUIT $SELECT(+Y>0:+Y,1:-1)
+7 ;
CODT(PXBEXIT) ;Ask the user the Check out Date/Time
+1 NEW DATA,PXCHKOUT
+2 DO CHIKOUT^PXBAPI2("",PXBPAT,PXBHLOC,PXBVSTDT)
+3 SET PXBCODT=PXCHKOUT
+4 if PXCHKOUT=-1
SET PXBCODT=""
+5 ;; PX*1*113 - Change for EAS*1*3 Appointment processing removed
+6 ;S X="EASMTCHK" X ^%ZOSF("TEST") I $T D Q:PXBEXIT<1
+7 ;. S:$G(EASACT)'="W" EASACT="C"
+8 ;. I $$MT^EASMTCHK(PXBPAT,"",EASACT,PXBVSTDT) D S PXBEXIT=-1
+9 ;. . D PAUSE^VALM1
+10 IF WHAT'["ADDEDIT"
IF PXCHKOUT=-1
SET PXBEXIT=-1
+11 IF $GET(PXBVST)
IF $$DISPOSIT^PXUTL1(PXBPAT,$PIECE($GET(^AUPNVSIT(PXBVST,0)),"^",1),PXBVST)
SET PXBEXIT=1
+12 ;make call to determine patient eligibility
+13 NEW ELIG
SET ELIG=$$ELIG^DGCOMPACTELIG(PXBPAT,"PXBAPI1")
+14 WRITE !!,"COMPACT Act Administrative Eligibility: ",ELIG
+15 IF ELIG'="NOT ELIGIBLE"
Begin DoDot:1
+16 SET DATA=$$DISPLAY^PXCOMPACT(PXBPAT)
+17 IF DATA'=""
WRITE !,$PIECE(DATA,"^",1),": ",$PIECE(DATA,"^",2)," ",$PIECE(DATA,"^",3),": ",$PIECE(DATA,"^",4)
+18 KILL ^TMP("PXCOMPACT",$JOB,"ASC")
+19 ;prompt for Treatment Related To Acute Suicidal Crisis
+20 IF $$ASC^PXCOMPACT(PXBPAT)="N"
QUIT
+21 NEW DIR,Y,DIRUT
+22 SET DIR("A")="Was treatment for Acute Suicidal Crisis"
SET DIR(0)="Y"
+23 SET DIR("?")="Enter YES if visit is related to an Acute Suicidal Crisis or NO if it is not."
+24 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET Y=""
+25 SET ^TMP("PXCOMPACT",$JOB,"ASC")=$GET(Y)
End DoDot:1
+26 ;
+27 QUIT
+28 ;
SCC(PXBEXIT) ;Ask the user the Service connected conditions
+1 NEW PXBDATA,PXBCLASS,PXBOUTEN,PXDOD
+2 SET (PXBOUTEN,PXDOD)=""
+3 ;I $$APPOINT^PXUTL1(PXBPAT,PXBVSTDT,PXBHLOC) D
+4 ;. S PXBOUTEN=$P($G(^DPT(+PXBPAT,"S",+PXBVSTDT,0)),"^",20)
+5 ;E I $$DISPOSIT^PXUTL1(PXBPAT,PXBVSTDT,PXBVST) D
+6 ;. S PXBOUTEN=+$P($G(^DPT(+PXBPAT,"DIS",9999999-PXBVSTDT,0)),"^",18)
+7 ;I 'PXBOUTEN,$G(PXBVST)>0 S PXBOUTEN=$O(^SCE("AVSIT",PXBVST,0))
+8 ;D CLASS^PXBAPI21(PXBOUTEN,PXBPAT,PXBVSTDT,PXBHLOC)
+9 DO CLASS^PXBAPI21(PXBOUTEN,PXBPAT,PXBVSTDT,PXBHLOC,PXBVST)
+10 ;PX*1*111 - Add HNC
+11 ; changed 6/17/98 for MST enhancement
FOR PXBCLASS=1:1:8
IF $GET(PXBDATA("ERR",PXBCLASS))=4
SET PXBEXIT=-1
QUIT
+12 if PXBEXIT<1
QUIT
+13 IF $GET(PXDOD)
SET PXBEXIT=-1
QUIT
+14 SET PXB800(1)=$PIECE($GET(PXBDATA(3)),"^",2)
+15 SET PXB800(2)=$PIECE($GET(PXBDATA(1)),"^",2)
+16 SET PXB800(3)=$PIECE($GET(PXBDATA(2)),"^",2)
+17 SET PXB800(4)=$PIECE($GET(PXBDATA(4)),"^",2)
+18 ;added 6/17/98 for MST enhancement
SET PXB800(5)=$PIECE($GET(PXBDATA(5)),"^",2)
+19 ;PX*1*111 - Add HNC
+20 SET PXB800(6)=$PIECE($GET(PXBDATA(6)),"^",2)
+21 SET PXB800(7)=$PIECE($GET(PXBDATA(7)),"^",2)
+22 SET PXB800(8)=$PIECE($GET(PXBDATA(8)),"^",2)
+23 QUIT
+24 ;
VISIT(PXBEXIT) ;Create or edit the Visit
+1 ;Set up ^TMP("PXK",$J and call PXK
+2 KILL ^TMP("PXK",$JOB)
+3 NEW PXBNODE,PXBAFTER,PXKERROR
+4 FOR PXBNODE=0,21,150,800,811,812
Begin DoDot:1
+5 SET PXBAFTER(PXBNODE)=$SELECT(PXBVST>0:$GET(^AUPNVSIT(PXBVST,PXBNODE)),1:"")
+6 SET ^TMP("PXK",$JOB,"VST",1,PXBNODE,"BEFORE")=PXBAFTER(PXBNODE)
End DoDot:1
+7 IF PXBVST'>0
Begin DoDot:1
+8 SET $PIECE(PXBAFTER(0),"^",1)=PXBVSTDT
+9 SET $PIECE(PXBAFTER(0),"^",5)=PXBPAT
+10 SET $PIECE(PXBAFTER(0),"^",8)=$PIECE(^SC(PXBHLOC,0),"^",7)
+11 ;PX*1*124
if PXBAPPT>0
SET $PIECE(PXBAFTER(0),"^",7)="A"
+12 SET $PIECE(PXBAFTER(150),"^",3)="P"
+13 SET $PIECE(PXBAFTER(812),"^",2)=PXBPKG
+14 SET $PIECE(PXBAFTER(812),"^",3)=PXBSOURC
End DoDot:1
+15 SET $PIECE(PXBAFTER(0),"^",18)=$GET(PXBCODT)
+16 if $PIECE(PXBAFTER(0),"^",22)=""
SET $PIECE(PXBAFTER(0),"^",22)=PXBHLOC
+17 SET $PIECE(PXBAFTER(800),"^",1)=$GET(PXB800(1))
+18 SET $PIECE(PXBAFTER(800),"^",2)=$GET(PXB800(2))
+19 SET $PIECE(PXBAFTER(800),"^",3)=$GET(PXB800(3))
+20 SET $PIECE(PXBAFTER(800),"^",4)=$GET(PXB800(4))
+21 ;added 6/17/98 for MST enhancement
SET $PIECE(PXBAFTER(800),"^",5)=$GET(PXB800(5))
+22 ;PX*1*111 - Add HNC
+23 SET $PIECE(PXBAFTER(800),"^",6)=$GET(PXB800(6))
+24 SET $PIECE(PXBAFTER(800),"^",7)=$GET(PXB800(7))
+25 SET $PIECE(PXBAFTER(800),"^",8)=$GET(PXB800(8))
+26 IF $DATA(PXELAP)#2
Begin DoDot:1
+27 SET $PIECE(PXBAFTER(0),"^",21)=+PXELAP
End DoDot:1
+28 FOR PXBNODE=0,21,150,800,811,812
Begin DoDot:1
+29 SET ^TMP("PXK",$JOB,"VST",1,PXBNODE,"AFTER")=PXBAFTER(PXBNODE)
End DoDot:1
+30 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=$SELECT(PXBVST>0:PXBVST,1:"")
+31 SET ^TMP("PXK",$JOB,"SOR")=PXBSOURC
+32 DO EN1^PXKMAIN
+33 SET PXBVST=$GET(^TMP("PXK",$JOB,"VST",1,"IEN"))
+34 QUIT
+35 ;
CPT(PXBEXIT) ;Ask the user Providers and CTPs
+1 DO CPT^PXBMCPT(PXBVST)
KILL PRVDR
+2 QUIT
+3 ;
POV(PXBEXIT) ;Ask the user Diagnoses
+1 DO POV^PXBMPOV(PXBVST)
KILL PRVDR
+2 QUIT
+3 ;
PRV(PXBEXIT) ;Ask the user Providers
+1 DO PRV^PXBMPRV(PXBVST,"PRV")
KILL PRVDR
+2 QUIT
+3 ;
STP(PXBEXIT) ;Ask the user Stop Codes
+1 IF $LENGTH($TEXT(DATE^SCDXUTL))
IF $$DATE^SCDXUTL(+$GET(^AUPNVSIT(PXBVST,0)))
QUIT
+2 DO STP^PXBMSTP(PXBVST)
KILL PRVDR
+3 QUIT
