PXCEPAT ;ISL/dee,ISA/KWP - Creates the List Manager display of visit for a patient ; 6/3/03 10:47am ; Compiled January 5, 2007 14:12:43
;;1.0;PCE PATIENT CARE ENCOUNTER;**1,5,14,30,70,147,160,161,183,188**;Aug 12, 1996;Build 3
Q
;
NEWPAT2 ;Entry point of changing patient from Update Encounter
N PXCENEWP
D PATIENT(.PXCENEWP)
Q:PXCENEWP'>0
D PATKILL
S PXCEPAT=+PXCENEWP
NEWPAT1 ;Entry point for initial selection of patient
D PATINFO(.PXCEPAT) Q:$D(DIRUT)
I $P(PXCEVIEW,"^",1)'="P" D
. S $P(PXCEVIEW,"^",1)="P"
. D SETDATES^PXCE
S SDAMTYP="P"
I PXCEVIEW["A" K PXCEHLOC
Q
;
NEWPAT ; -- init variables and list array
N PXCENEWP
D PATIENT(.PXCENEWP)
I PXCENEWP'>0,("~H~P~"'[("~"_$P(PXCEVIEW,"^")_"~")) S VALMQUIT=1 Q
I PXCENEWP'>0 Q
D PATKILL
S PXCEPAT=+PXCENEWP
D NEWPAT1 Q:$D(DIRUT)
D MAKELIST^PXCENEW
Q
;
MAKELIST ;
N PXCEDATE,PXCELOC,PXCESTAT,PXCEDT,PXCEIEN,PXCEVSIT,PXCEPRIM
D CHGCAP^VALM("LOCATION","Clinic")
K VALMHDR S VALMBCK="R"
S PXCEDT=PXCE9END
D CLEAN^VALM10
K ^TMP("PXCEIDX",$J)
S VALMBG=1
S VALMCNT=0
F S PXCEDT=$O(^AUPNVSIT("AA",PXCEPAT,PXCEDT)) Q:PXCEDT'>0!(PXCEDT>PXCE9BEG) D
. S PXCEIEN=""
. F S PXCEIEN=$O(^AUPNVSIT("AA",PXCEPAT,PXCEDT,PXCEIEN)) Q:PXCEIEN'>0 D
.. S PXCEVSIT=^AUPNVSIT(PXCEIEN,0)
.. I $D(PXCEHLOC),$P(PXCEVSIT,"^",22)'=PXCEHLOC Q
.. S PXCEPRIM=$P($G(^AUPNVSIT(PXCEIEN,150)),"^",3)
.. ;+do not show encounter if the encounter type is S,C or null
.. Q:"SC"[PXCEPRIM
.. I PXCEKEYS'["S",PXCEKEYS'["V","A"=PXCEPRIM Q ;+let supervisor and viewer see ancillary encounters
.. I PXCEKEYS'["V",$$DISPOSIT^PXUTL1(PXCEPAT,+PXCEVSIT,PXCEIEN) Q ;+let viewer see disposition
.. S VALMCNT=VALMCNT+1
.. S Y=$P(PXCEVSIT,"^",1)
.. S PXCEDATE=$$DATE^PXCEDATE($P(PXCEVSIT,"^",1))
.. S PXCEDATE=$E(PXCEDATE,1,18)_$J("",(19-$L(PXCEDATE)))
.. I $P(PXCEVSIT,"^",7)="E" D
... S PXCELOC=" Historical Encounter at "
... I $P(PXCEVSIT,"^",6)]"" D
.... N PXCEDELF
.... S PXCESTAT=$E($$EXTERNAL^DILFD(9000010,.06,"",$P(PXCEVSIT,"^",6),"PXCEDILF"),1,30)
... E S PXCESTAT=$E($P($G(^AUPNVSIT(PXCEIEN,21)),"^"),1,30)
.. E D
... S PXCELOC=$S($P(PXCEVSIT,"^",22)>0:$P(^SC($P(PXCEVSIT,"^",22),0),"^"),$P(PXCEVSIT,"^",7)="E":" Historical",1:"")
... S PXCELOC=$E(PXCELOC,1,26)_$J("",(28-$L(PXCELOC)))
... S PXCESTAT=$P($$STATUS^SDPCE(PXCEIEN),"^",2)
.. S ^TMP("PXCE",$J,VALMCNT,0)=$J(VALMCNT,4)_" "_PXCEDATE_PXCELOC_PXCESTAT
.. S ^TMP("PXCEIDX",$J,VALMCNT)=PXCEIEN
S ^TMP("PXCEIDX",$J,0)=VALMCNT
I VALMCNT'>0 D
. S ^TMP("PXCE",$J,1,0)=" "
. S ^TMP("PXCE",$J,2,0)=" No encounter found that satisfy the above criteria."
. S VALMCNT=2
Q
;
SDSALONE ;Get the patient for standalone from the appointment/hospital
;location screen
Q:$G(PXCEPAT)>0
D PATIENT(.PXCEPAT)
I PXCEPAT>0 D PATINFO(.PXCEPAT) S PXCEJPAT=1
Q
;
SDKALONE ;Kill the patient info if it was created above
Q:'$D(PXCEJPAT)
D PATKILL
K PXCEJPAT
Q
;
JUSTDFN ;Just set DFN for other packages.
Q
Q:$G(DFN)>0
N X,Y,DIC,DA
S DIC=2,DIC(0)="AEMQ"
D ^DIC
I +Y>0 S DFN=+Y,PXCEJDFN=1
Q
;
JUSTDFNK ;Kill DFN if it was set above
I $G(PXCEJDFN) K DFN,PXCEJDFN
I $G(PXCEPAT)>0 S DFN=PXCEPAT
Q
;
PATIENT(PXCEDATA) ; Select a patient
N X,Y,DIC,DA,DFN
D FULL^VALM1
S DIC=2,DIC(0)="AEMQ" D ^DIC
S PXCEDATA=+Y
PAT1 S %=1 I Y>0 W !," ...OK" D YN^DICN I %=0 W " Answer With 'Yes' or 'No'" G PAT1
I %'=1!$D(DIRUT) S (Y,PXCEDATA)=-1
I +Y'>0 D Q
. I $G(DFN)'>0 S VALMSG=$C(7)_"Patient has not been selected." W !!,$G(VALMSG) H 1
I +Y>0 S DFN=+Y D 2^VADPT I +VADM(6) N DIR D I $D(DIRUT) S PXCEDATA=-1
. S DIR(0)="E",DIR("A")="Enter RETURN to continue or '^' to exit"
. S DIR("A",1)="WARNING "_VADM(7) D ^DIR
Q
;
PATINFO(PXCEDATA) ;
Q:$G(PXCEDATA)'>0
S (DFN,SDFN,ORVP)=PXCEDATA
D:$G(PXCECAT)="SIT"!($G(PXCECAT)="HIST")!($G(PXCECAT)="AEP")!$G(FSEL) DTHINFO
I $D(DIRUT),$G(FSEL) D PATKILL Q
;D 2^VADPT I +VADM(6) D K DIR I $D(DIRUT) D:$G(PXCECAT)'="SIT"&($G(PXCECAT)'="HIST")&($G(PXCECAT)'="AEP") PATKILL Q
;. S DIR(0)="E",DIR("A")="Enter RETURN to continue or '^' to Quit"
;. S DIR("A",2)="WARNING "_VADM(7),DIR("A",1)=" ",DIR("A",3)=" " D ^DIR
N Y
S Y=PXCEDATA
;Set IHS patient variables
D START^AUPNPAT
D PATNAME(.PXCEDATA)
N VAERR,VAROOT,PXCEVA,PXCEINDX
S VAROOT="PXCEVA"
D ELIG^VADPT
S PXCEDATA("ELIG")=$P($G(PXCEVA(1)),"^",1,99)
S PXCEINDX=""
F S PXCEINDX=$O(PXCEVA(1,PXCEINDX)) Q:'PXCEINDX S PXCEDATA("ELIG",PXCEINDX)=$P(PXCEVA(1,PXCEINDX),"^",1,99)
Q
;
DTHINFO ;DEATH WARNING
D 2^VADPT N DIR I +VADM(6) D
. S DIR(0)="E",DIR("A")="Enter RETURN to continue or '^' to Quit"
. S DIR("A",2)="WARNING "_VADM(7),DIR("A",1)=" ",DIR("A",3)=" " D ^DIR
Q
PATNAME(PXCEDATA) ;
S PXCEDATA("NAME")=$P($G(^DPT(+PXCEDATA,0)),"^",1)
N VAPTYP,VA,VAERR,DFN
S DFN=+PXCEDATA
D PID^VADPT6
I 'VAERR S PXCEDATA("SSN")=VA("PID"),PXCEDATA("SSN_BRIEF")=VA("BID")
E S (PXCEDATA("SSN"),PXCEDATA("SSN_BRIEF"))=""
Q
;
PATKILL ;
K PXCEPAT,DFN,SDFN,ORVP,VADM,VAEL,VALMSG
; Kill IHS patient variables
D KILL^AUPNPAT
Q
;
APPOINT(DFN,DATETIME,HOSLOC) ;See if there is an appointment.
;Input:
; DFN ien of the patient
; DATETIME the date and time of the appointment
; HOSLOC optional, is the Hospital Location (#44)
;Returns the clinic ien or -1 if no appointement.
;
N VASD,HL,INDEX,VAERR
K ^UTILITY("VASD",$J)
S VASD("T")=DATETIME
S VASD("F")=DATETIME-.00000001
S VASD("W")=129 ;1)Active/Kept 2)Inpatient appts. only 9)No action taken
S:$G(HOSLOC) VASD("C",HOSLOC)=""
D SDA^VADPT
I VAERR S HL=-1 G QAPPOINT
S INDEX=$O(^UTILITY("VASD",$J,0))
I INDEX>0 S HL=$P(^UTILITY("VASD",$J,INDEX,"I"),"^",2)
E S HL=-1
QAPPOINT K ^UTILITY("VASD",$J)
Q HL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEPAT 5810 printed Apr 09, 2024@21:31:17 Page 2
PXCEPAT ;ISL/dee,ISA/KWP - Creates the List Manager display of visit for a patient ; 6/3/03 10:47am ; Compiled January 5, 2007 14:12:43
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,5,14,30,70,147,160,161,183,188**;Aug 12, 1996;Build 3
+2 QUIT
+3 ;
NEWPAT2 ;Entry point of changing patient from Update Encounter
+1 NEW PXCENEWP
+2 DO PATIENT(.PXCENEWP)
+3 if PXCENEWP'>0
QUIT
+4 DO PATKILL
+5 SET PXCEPAT=+PXCENEWP
NEWPAT1 ;Entry point for initial selection of patient
+1 DO PATINFO(.PXCEPAT)
if $DATA(DIRUT)
QUIT
+2 IF $PIECE(PXCEVIEW,"^",1)'="P"
Begin DoDot:1
+3 SET $PIECE(PXCEVIEW,"^",1)="P"
+4 DO SETDATES^PXCE
End DoDot:1
+5 SET SDAMTYP="P"
+6 IF PXCEVIEW["A"
KILL PXCEHLOC
+7 QUIT
+8 ;
NEWPAT ; -- init variables and list array
+1 NEW PXCENEWP
+2 DO PATIENT(.PXCENEWP)
+3 IF PXCENEWP'>0
IF ("~H~P~"'[("~"_$PIECE(PXCEVIEW,"^")_"~"))
SET VALMQUIT=1
QUIT
+4 IF PXCENEWP'>0
QUIT
+5 DO PATKILL
+6 SET PXCEPAT=+PXCENEWP
+7 DO NEWPAT1
if $DATA(DIRUT)
QUIT
+8 DO MAKELIST^PXCENEW
+9 QUIT
+10 ;
MAKELIST ;
+1 NEW PXCEDATE,PXCELOC,PXCESTAT,PXCEDT,PXCEIEN,PXCEVSIT,PXCEPRIM
+2 DO CHGCAP^VALM("LOCATION","Clinic")
+3 KILL VALMHDR
SET VALMBCK="R"
+4 SET PXCEDT=PXCE9END
+5 DO CLEAN^VALM10
+6 KILL ^TMP("PXCEIDX",$JOB)
+7 SET VALMBG=1
+8 SET VALMCNT=0
+9 FOR
SET PXCEDT=$ORDER(^AUPNVSIT("AA",PXCEPAT,PXCEDT))
if PXCEDT'>0!(PXCEDT>PXCE9BEG)
QUIT
Begin DoDot:1
+10 SET PXCEIEN=""
+11 FOR
SET PXCEIEN=$ORDER(^AUPNVSIT("AA",PXCEPAT,PXCEDT,PXCEIEN))
if PXCEIEN'>0
QUIT
Begin DoDot:2
+12 SET PXCEVSIT=^AUPNVSIT(PXCEIEN,0)
+13 IF $DATA(PXCEHLOC)
IF $PIECE(PXCEVSIT,"^",22)'=PXCEHLOC
QUIT
+14 SET PXCEPRIM=$PIECE($GET(^AUPNVSIT(PXCEIEN,150)),"^",3)
+15 ;+do not show encounter if the encounter type is S,C or null
+16 if "SC"[PXCEPRIM
QUIT
+17 ;+let supervisor and viewer see ancillary encounters
IF PXCEKEYS'["S"
IF PXCEKEYS'["V"
IF "A"=PXCEPRIM
QUIT
+18 ;+let viewer see disposition
IF PXCEKEYS'["V"
IF $$DISPOSIT^PXUTL1(PXCEPAT,+PXCEVSIT,PXCEIEN)
QUIT
+19 SET VALMCNT=VALMCNT+1
+20 SET Y=$PIECE(PXCEVSIT,"^",1)
+21 SET PXCEDATE=$$DATE^PXCEDATE($PIECE(PXCEVSIT,"^",1))
+22 SET PXCEDATE=$EXTRACT(PXCEDATE,1,18)_$JUSTIFY("",(19-$LENGTH(PXCEDATE)))
+23 IF $PIECE(PXCEVSIT,"^",7)="E"
Begin DoDot:3
+24 SET PXCELOC=" Historical Encounter at "
+25 IF $PIECE(PXCEVSIT,"^",6)]""
Begin DoDot:4
+26 NEW PXCEDELF
+27 SET PXCESTAT=$EXTRACT($$EXTERNAL^DILFD(9000010,.06,"",$PIECE(PXCEVSIT,"^",6),"PXCEDILF"),1,30)
End DoDot:4
+28 IF '$TEST
SET PXCESTAT=$EXTRACT($PIECE($GET(^AUPNVSIT(PXCEIEN,21)),"^"),1,30)
End DoDot:3
+29 IF '$TEST
Begin DoDot:3
+30 SET PXCELOC=$SELECT($PIECE(PXCEVSIT,"^",22)>0:$PIECE(^SC($PIECE(PXCEVSIT,"^",22),0),"^"),$PIECE(PXCEVSIT,"^",7)="E":" Historical",1:"")
+31 SET PXCELOC=$EXTRACT(PXCELOC,1,26)_$JUSTIFY("",(28-$LENGTH(PXCELOC)))
+32 SET PXCESTAT=$PIECE($$STATUS^SDPCE(PXCEIEN),"^",2)
End DoDot:3
+33 SET ^TMP("PXCE",$JOB,VALMCNT,0)=$JUSTIFY(VALMCNT,4)_" "_PXCEDATE_PXCELOC_PXCESTAT
+34 SET ^TMP("PXCEIDX",$JOB,VALMCNT)=PXCEIEN
End DoDot:2
End DoDot:1
+35 SET ^TMP("PXCEIDX",$JOB,0)=VALMCNT
+36 IF VALMCNT'>0
Begin DoDot:1
+37 SET ^TMP("PXCE",$JOB,1,0)=" "
+38 SET ^TMP("PXCE",$JOB,2,0)=" No encounter found that satisfy the above criteria."
+39 SET VALMCNT=2
End DoDot:1
+40 QUIT
+41 ;
SDSALONE ;Get the patient for standalone from the appointment/hospital
+1 ;location screen
+2 if $GET(PXCEPAT)>0
QUIT
+3 DO PATIENT(.PXCEPAT)
+4 IF PXCEPAT>0
DO PATINFO(.PXCEPAT)
SET PXCEJPAT=1
+5 QUIT
+6 ;
SDKALONE ;Kill the patient info if it was created above
+1 if '$DATA(PXCEJPAT)
QUIT
+2 DO PATKILL
+3 KILL PXCEJPAT
+4 QUIT
+5 ;
JUSTDFN ;Just set DFN for other packages.
+1 QUIT
+2 if $GET(DFN)>0
QUIT
+3 NEW X,Y,DIC,DA
+4 SET DIC=2
SET DIC(0)="AEMQ"
+5 DO ^DIC
+6 IF +Y>0
SET DFN=+Y
SET PXCEJDFN=1
+7 QUIT
+8 ;
JUSTDFNK ;Kill DFN if it was set above
+1 IF $GET(PXCEJDFN)
KILL DFN,PXCEJDFN
+2 IF $GET(PXCEPAT)>0
SET DFN=PXCEPAT
+3 QUIT
+4 ;
PATIENT(PXCEDATA) ; Select a patient
+1 NEW X,Y,DIC,DA,DFN
+2 DO FULL^VALM1
+3 SET DIC=2
SET DIC(0)="AEMQ"
DO ^DIC
+4 SET PXCEDATA=+Y
PAT1 SET %=1
IF Y>0
WRITE !," ...OK"
DO YN^DICN
IF %=0
WRITE " Answer With 'Yes' or 'No'"
GOTO PAT1
+1 IF %'=1!$DATA(DIRUT)
SET (Y,PXCEDATA)=-1
+2 IF +Y'>0
Begin DoDot:1
+3 IF $GET(DFN)'>0
SET VALMSG=$CHAR(7)_"Patient has not been selected."
WRITE !!,$GET(VALMSG)
HANG 1
End DoDot:1
QUIT
+4 IF +Y>0
SET DFN=+Y
DO 2^VADPT
IF +VADM(6)
NEW DIR
Begin DoDot:1
+5 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue or '^' to exit"
+6 SET DIR("A",1)="WARNING "_VADM(7)
DO ^DIR
End DoDot:1
IF $DATA(DIRUT)
SET PXCEDATA=-1
+7 QUIT
+8 ;
PATINFO(PXCEDATA) ;
+1 if $GET(PXCEDATA)'>0
QUIT
+2 SET (DFN,SDFN,ORVP)=PXCEDATA
+3 if $GET(PXCECAT)="SIT"!($GET(PXCECAT)="HIST")!($GET(PXCECAT)="AEP")!$GET(FSEL)
DO DTHINFO
+4 IF $DATA(DIRUT)
IF $GET(FSEL)
DO PATKILL
QUIT
+5 ;D 2^VADPT I +VADM(6) D K DIR I $D(DIRUT) D:$G(PXCECAT)'="SIT"&($G(PXCECAT)'="HIST")&($G(PXCECAT)'="AEP") PATKILL Q
+6 ;. S DIR(0)="E",DIR("A")="Enter RETURN to continue or '^' to Quit"
+7 ;. S DIR("A",2)="WARNING "_VADM(7),DIR("A",1)=" ",DIR("A",3)=" " D ^DIR
+8 NEW Y
+9 SET Y=PXCEDATA
+10 ;Set IHS patient variables
+11 DO START^AUPNPAT
+12 DO PATNAME(.PXCEDATA)
+13 NEW VAERR,VAROOT,PXCEVA,PXCEINDX
+14 SET VAROOT="PXCEVA"
+15 DO ELIG^VADPT
+16 SET PXCEDATA("ELIG")=$PIECE($GET(PXCEVA(1)),"^",1,99)
+17 SET PXCEINDX=""
+18 FOR
SET PXCEINDX=$ORDER(PXCEVA(1,PXCEINDX))
if 'PXCEINDX
QUIT
SET PXCEDATA("ELIG",PXCEINDX)=$PIECE(PXCEVA(1,PXCEINDX),"^",1,99)
+19 QUIT
+20 ;
DTHINFO ;DEATH WARNING
+1 DO 2^VADPT
NEW DIR
IF +VADM(6)
Begin DoDot:1
+2 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue or '^' to Quit"
+3 SET DIR("A",2)="WARNING "_VADM(7)
SET DIR("A",1)=" "
SET DIR("A",3)=" "
DO ^DIR
End DoDot:1
+4 QUIT
PATNAME(PXCEDATA) ;
+1 SET PXCEDATA("NAME")=$PIECE($GET(^DPT(+PXCEDATA,0)),"^",1)
+2 NEW VAPTYP,VA,VAERR,DFN
+3 SET DFN=+PXCEDATA
+4 DO PID^VADPT6
+5 IF 'VAERR
SET PXCEDATA("SSN")=VA("PID")
SET PXCEDATA("SSN_BRIEF")=VA("BID")
+6 IF '$TEST
SET (PXCEDATA("SSN"),PXCEDATA("SSN_BRIEF"))=""
+7 QUIT
+8 ;
PATKILL ;
+1 KILL PXCEPAT,DFN,SDFN,ORVP,VADM,VAEL,VALMSG
+2 ; Kill IHS patient variables
+3 DO KILL^AUPNPAT
+4 QUIT
+5 ;
APPOINT(DFN,DATETIME,HOSLOC) ;See if there is an appointment.
+1 ;Input:
+2 ; DFN ien of the patient
+3 ; DATETIME the date and time of the appointment
+4 ; HOSLOC optional, is the Hospital Location (#44)
+5 ;Returns the clinic ien or -1 if no appointement.
+6 ;
+7 NEW VASD,HL,INDEX,VAERR
+8 KILL ^UTILITY("VASD",$JOB)
+9 SET VASD("T")=DATETIME
+10 SET VASD("F")=DATETIME-.00000001
+11 ;1)Active/Kept 2)Inpatient appts. only 9)No action taken
SET VASD("W")=129
+12 if $GET(HOSLOC)
SET VASD("C",HOSLOC)=""
+13 DO SDA^VADPT
+14 IF VAERR
SET HL=-1
GOTO QAPPOINT
+15 SET INDEX=$ORDER(^UTILITY("VASD",$JOB,0))
+16 IF INDEX>0
SET HL=$PIECE(^UTILITY("VASD",$JOB,INDEX,"I"),"^",2)
+17 IF '$TEST
SET HL=-1
QAPPOINT KILL ^UTILITY("VASD",$JOB)
+1 QUIT HL
+2 ;
