PXCE ;ISL/dee - Main routine for PCE's user interface ; 3/27/01 12:17pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**25,47,52,64,75,78,147,151,161**;Aug 12, 1996
;
;PXCEKEYS is a set of letters that enable the user
; to enter certain fields
; "P" is included if the user holds the AK.PROVIDER key.
; "C" should be included by the option if the user should be
; asked for the Provider Narrative Categories on V CPT, V POV,
; and V TREATMENT files. As well as for other fields that are
; not ask of the normal user.
; "S" is for the superviser. If they have "S" then they will be
; given "C" and "D" by the program.
; "V" is for view only
; And if it:
; includes "D" to delete any V-File
; includes "d" to only delete V-File entries this user created
;
I '$D(PXCEKEYS)#2 N PXCEKEYS S PXCEKEYS=""
S:PXCEKEYS'["D" PXCEKEYS=PXCEKEYS_"D"
G START
; -- main entry point for PCE's user interface
EN1(PXCEKEYS) ;Does not checks for provider
G START1
EN(PXCEKEYS) ;Checks for provider
;
START ;
;Key for provider (P)
I PXCEKEYS'["P",$O(^VA(200,"AK.PROVIDER",$P(^VA(200,DUZ,0),"^"),""))=DUZ S PXCEKEYS=PXCEKEYS_"P"
START1 ;
;If they have the Key for superviser (S) make sure that they also
; have C and D.
I PXCEKEYS["S" S:PXCEKEYS'["C" PXCEKEYS=PXCEKEYS_"C" S:PXCEKEYS'["D" PXCEKEYS=PXCEKEYS_"D"
;
K I,X,SDB,XQORNOD,SDFN,SDCLN,DA,DR,DIE,DNM,DQ,%B
N PXCEVIEW,SDAMTYP
N PXCEPAT,PXCEHLOC
N PXCEDBEG,PXCEDEND,PXCE9BEG,PXCE9END,SDBEG,SDEND
N PXCEDBP,PXCEDBHL,PXCEDEP,PXCEDEHL
N PXCECONT
N PXCESOR,PXCEPKG
I $G(DFN)'>0 N DFN
;
S PXCEVIEW="^"_$S("~V~A~"["~"_$P(^PX(815,1,"LM"),"^",2)_"~":$P(^PX(815,1,"LM"),"^",2),1:"V")_"^"
S PXCESOR=$$SOURCE^PXAPIUTL("PXCE DATA ENTRY")
S PXCEPKG=$$PKG2IEN^VSIT("PX")
;
K DIRUT
D SETUP Q:$D(DIRUT)
;
F D Q:$D(PXCEVIEW)'=1!'$D(PXCECONT)
. K PXCECONT
. I PXCEKEYS["V" D
.. I PXCEVIEW["A" D
... D EN^VALM("PXCE SDAM VIEW ONLY")
.. E D EN^VALM("PXCE VIEW ONLY")
. E I PXCEVIEW["A" D
.. D EN^VALM("PXCE SDAM MENU")
. E D EN^VALM("PXCE MAIN MENU")
D FULL^VALM1
D EXITALL
Q
;
SETUP ;
N DIR,DA,X,Y,PXRES
N PXCEUSEL,X1,X2
I $G(DFN)>0 S PXCEUSEL=DFN_"^DPT("
E S DIR(0)="815,201",DIR("A")="Select Patient or Clinic name" D ^DIR K DIR,DA Q:$D(DIRUT) S PXCEUSEL=Y
S X1=DT,X2=$S($P(^PX(815,1,"LM"),"^",3)]"":$P(^PX(815,1,"LM"),"^",3),1:-30) D C^%DTC
S PXCEDBP=X
S X1=DT,X2=$S($P(^PX(815,1,"LM"),"^",4)]"":$P(^PX(815,1,"LM"),"^",4),1:0) D C^%DTC
S PXCEDEP=X
S X1=DT,X2=$S($P(^PX(815,1,"LM"),"^",5)]"":$P(^PX(815,1,"LM"),"^",5),1:-7) D C^%DTC
S PXCEDBHL=X
S X1=DT,X2=$S($P(^PX(815,1,"LM"),"^",6)]"":$P(^PX(815,1,"LM"),"^",6),1:0) D C^%DTC
S PXCEDEHL=X
I PXCEUSEL["DPT(" S $P(PXCEVIEW,"^",1)="P" S SDAMTYP="P"
I PXCEUSEL["SC(" S $P(PXCEVIEW,"^",1)="H" S SDAMTYP="C" D I 'PXRES G SETUP
.S PXRES=$$CLNCK^SDUTL2(+PXCEUSEL,1)
.I 'PXRES W !,?5,"Clinic MUST be corrected before continuing."
D SETDATES
I PXCEUSEL["DPT(" S PXCEPAT=+PXCEUSEL,FSEL=1 D NEWPAT1^PXCEPAT K FSEL G:$D(DIRUT) SETUP
I PXCEUSEL["SC(" S PXCEHLOC=+PXCEUSEL D NEWHOSL1^PXCENEW
Q
;
SETDATES ;
I PXCEVIEW["H" D
. S PXCEDBEG=PXCEDBHL
. S PXCEDEND=PXCEDEHL
E D
. S PXCEDBEG=PXCEDBP
. S PXCEDEND=PXCEDEP
D DATE9S^PXCEDATE
Q
;
HDR ; -- header code
K VALMHDR,PXLNX,PXPCP
S PXLNX=1,PXPCP=""
;
;PATIENT
I PXCEVIEW["P" D
. S PXPCP=$$PCLINE^SDPPTEM(PXCEPAT,DT)
. S VALMHDR(PXLNX)=$E(PXCEPAT("NAME"),1,26)
. S VALMHDR(PXLNX)=$E(VALMHDR(PXLNX)_$E(" ",1,(27-$L(VALMHDR(PXLNX))))_PXCEPAT("SSN")_" ",1,40)
E S VALMHDR(PXLNX)=" "
;LOCATION
S VALMHDR(PXLNX)=VALMHDR(PXLNX)_"Clinic: "_$S($G(PXCEHLOC)&(PXCEVIEW'["P^A"):$P(^SC(PXCEHLOC,0),"^"),1:"All")
S PXLNX=PXLNX+1
I $L(PXPCP) S VALMHDR(PXLNX)=PXPCP,PXLNX=PXLNX+1
;
;DATE
S VALMHDR(PXLNX)=$E("Date range: "_$$FMTE^XLFDT(PXCEDBEG,5)_" to "_$$FMTE^XLFDT(PXCEDEND,5)_$J("",40),1,40)
;
;Credit Stop
S:PXCEVIEW["A" VALMHDR(PXLNX)=VALMHDR(PXLNX)_$P($G(SDAMLIST),"^",2)
S PXLNX=PXLNX+1
;
;CHECK IF GAF NEEDED
I PXCEVIEW'["P",$$MHCLIN^SDUTL2(PXCEHLOC) S VALMHDR(PXLNX)=$$SETSTR^VALM1("* - New GAF Score Required","",25,80)
I PXCEVIEW["P" D
.S VALMHDR(PXLNX)=$$SETSTR^VALM1("* - New GAF Score Required","",25,80)
.N PXCEHLC,PXCESTA
.K PXCEHIT
.S PXCESTA=$$ELSTAT^SDUTL2(PXCEPAT)
.S PXCEZZ=0
.F S PXCEZZ=$O(^TMP("PXCEIDX",$J,PXCEZZ)) Q:PXCEZZ'>0 D Q:$D(PXCEHIT)
..S PXCEHLC=+$P($G(^AUPNVSIT(^TMP("PXCEIDX",$J,PXCEZZ),0)),"^",22)
..I $$MHCLIN^SDUTL2(PXCEHLC),'$$COLLAT^SDUTL2(PXCESTA) D
...S PXCEGAF=$$NEWGAF^SDUTL2($S($D(SDFN):SDFN,$D(PXCEPAT):PXCEPAT,1:""))
...S PXCEGST=$P(PXCEGAF,"^")
...I PXCEGST D
....S PXCEGDT=$$FMTE^XLFDT($P(PXCEGAF,"^",3),"5M"),PXCEGSC=$P(PXCEGAF,"^",2),PXCEGPR=$P(PXCEGAF,"^",4)
....S VALMHDR(PXLNX)="GAF Date: "_PXCEGDT_" GAF Score:"_PXCEGSC_" NEW REQ",PXCEHIT=1
;
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
INIT ; -- init variables and list array
D MAKELIST^PXCENEW
Q
;
EXIT ; -- exit code
D FULL^VALM1
D CLEAN^VALM10
K ^TMP("PXCE",$J)
K ^TMP("PXCEIDX",$J)
D FNL^PXCESDAM
Q
;
EXITALL ; Exit of whole program
D PATKILL^PXCEPAT
D KVA^VADPT
Q
;
DONE ; -- exit action for protocol
S:'$D(VALMBCK) VALMBCK="R"
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
EXPND ; -- expand code
D EN^PXCEEXP
Q
;
SEL1(HELP,PXCEADD) ; Select 1 visit
; If the $GET(PXCEADD) is non zero then will
; add to the prompt "add a new encounter"
N X,Y,MAX
S MAX=+$G(^TMP("PXCEIDX",$J,0)) I MAX'>0 Q "^"
S Y=$P($P(XQORNOD(0),"^",4),"=",2)
I Y]"" D
. I (+Y'=Y)!(+Y>MAX)!(+Y<1)!(Y#1'=0) D
.. W !,$C(7),"Selection '",Y,"' is not a valid choice."
.. D PAUSE^PXCEHELP
.. S Y="^"
E I '$G(PXCEADD) D
. N DIR,DA
. S DIR(0)="NAO^1:"_MAX_":0",DIR("A")="Select Encounter"
. S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
. S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
. S DIR("?")="Enter the number of the Encounter you wish to "
. S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")
. D ^DIR I $D(DTOUT)!(X="") S Y="^"
E D
. N DIR,DA
ASKLOOP . S DIR(0)="FAO^1:"_$L(MAX)
. S DIR("A")="Enter 1-"_MAX_" to Edit, or 'A' to Add: "
. S DIR("?")="Enter the number of the Encounter you wish "
. S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")_" or A to "
. S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")_" add a new Encounter"
. D ^DIR
. K DIR,DA
. I $D(DIRUT)!(X="") S Y="^" Q
. I "Aa"[Y S Y="A" Q
. G:Y<1!(Y>MAX) ASKLOOP
Q Y
;
GAF ;;
N PXCEVIEN,PXDFN,PXDSS,PXELIG,PXDATA
I $G(PXCEHLOC),'$$MHCLIN^SDUTL2(PXCEHLOC) D G SKIP
. S DIR(0)="FOA"
. S DIR("A",1)=" This is not a Mental Health Clinic, a GAF Score may not be entered."
. S DIR("A")=" Press any key to continue: "
. D ^DIR K DIR
;
I $D(^TMP("PXCEIDX",$J)) D GETVIEN^PXCEAE
I $D(^TMP("SDAMIDX",$J)) S PXCEVIEN=$$SELAPPM^PXCESDAM
I '($G(PXCEVIEN)]"")!($G(PXCEVIEN)=-1) D S VALMBCK="R" Q
. S DIR(0)="FAO"
. I '($G(PXCEVIEN)]"") S DIR("A",1)="Nothing to select."
. I $G(PXCEVIEN)=-1 S DIR("A",1)="No selections made."
. S DIR("A")="Press any key to continue."
. D ^DIR K DIR
S PXDFN=$P($G(^AUPNVSIT(PXCEVIEN,0)),"^",5)
S PXDSS=$P($G(^AUPNVSIT(PXCEVIEN,0)),"^",8)
S PXDATA=$G(^DPT(PXDFN,"S",$P(^AUPNVSIT(PXCEVIEN,0),U),0))
S PXELIG=$$ELSTAT^SDUTL2(PXDFN)
I $$MHCLIN^SDUTL2("",PXDSS),'($$COLLAT^SDUTL2(PXELIG)!$P(PXDATA,U,11)) D
. S PXGAF=$$NEWGAF^SDUTL2(PXDFN)
. D FULL^VALM1
. W !
. I +$P(PXGAF,U,5)>0 W !,"Warning: Patient is deceased."
. W !,"Current GAF: "_+$P(PXGAF,U,2)
. W $S($P(PXGAF,U,3)>0:", from "_$$FMTE^XLFDT($P(PXGAF,U,3),"D"),1:", Date Unavailable")
. D EN^SDGAF(PXDFN)
E D
. S DIR(0)="FOA"
. S DIR("A",1)="A GAF Score is not required for this appointment!"
. S DIR("A")="Press any key to continue: "
. D ^DIR K DIR
;
SKIP S VALMBCK="R"
GAFQ Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCE 7979 printed Apr 09, 2024@21:28:44 Page 2
PXCE ;ISL/dee - Main routine for PCE's user interface ; 3/27/01 12:17pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**25,47,52,64,75,78,147,151,161**;Aug 12, 1996
+2 ;
+3 ;PXCEKEYS is a set of letters that enable the user
+4 ; to enter certain fields
+5 ; "P" is included if the user holds the AK.PROVIDER key.
+6 ; "C" should be included by the option if the user should be
+7 ; asked for the Provider Narrative Categories on V CPT, V POV,
+8 ; and V TREATMENT files. As well as for other fields that are
+9 ; not ask of the normal user.
+10 ; "S" is for the superviser. If they have "S" then they will be
+11 ; given "C" and "D" by the program.
+12 ; "V" is for view only
+13 ; And if it:
+14 ; includes "D" to delete any V-File
+15 ; includes "d" to only delete V-File entries this user created
+16 ;
+17 IF '$DATA(PXCEKEYS)#2
NEW PXCEKEYS
SET PXCEKEYS=""
+18 if PXCEKEYS'["D"
SET PXCEKEYS=PXCEKEYS_"D"
+19 GOTO START
+20 ; -- main entry point for PCE's user interface
EN1(PXCEKEYS) ;Does not checks for provider
+1 GOTO START1
EN(PXCEKEYS) ;Checks for provider
+1 ;
START ;
+1 ;Key for provider (P)
+2 IF PXCEKEYS'["P"
IF $ORDER(^VA(200,"AK.PROVIDER",$PIECE(^VA(200,DUZ,0),"^"),""))=DUZ
SET PXCEKEYS=PXCEKEYS_"P"
START1 ;
+1 ;If they have the Key for superviser (S) make sure that they also
+2 ; have C and D.
+3 IF PXCEKEYS["S"
if PXCEKEYS'["C"
SET PXCEKEYS=PXCEKEYS_"C"
if PXCEKEYS'["D"
SET PXCEKEYS=PXCEKEYS_"D"
+4 ;
+5 KILL I,X,SDB,XQORNOD,SDFN,SDCLN,DA,DR,DIE,DNM,DQ,%B
+6 NEW PXCEVIEW,SDAMTYP
+7 NEW PXCEPAT,PXCEHLOC
+8 NEW PXCEDBEG,PXCEDEND,PXCE9BEG,PXCE9END,SDBEG,SDEND
+9 NEW PXCEDBP,PXCEDBHL,PXCEDEP,PXCEDEHL
+10 NEW PXCECONT
+11 NEW PXCESOR,PXCEPKG
+12 IF $GET(DFN)'>0
NEW DFN
+13 ;
+14 SET PXCEVIEW="^"_$SELECT("~V~A~"["~"_$PIECE(^PX(815,1,"LM"),"^",2)_"~":$PIECE(^PX(815,1,"LM"),"^",2),1:"V")_"^"
+15 SET PXCESOR=$$SOURCE^PXAPIUTL("PXCE DATA ENTRY")
+16 SET PXCEPKG=$$PKG2IEN^VSIT("PX")
+17 ;
+18 KILL DIRUT
+19 DO SETUP
if $DATA(DIRUT)
QUIT
+20 ;
+21 FOR
Begin DoDot:1
+22 KILL PXCECONT
+23 IF PXCEKEYS["V"
Begin DoDot:2
+24 IF PXCEVIEW["A"
Begin DoDot:3
+25 DO EN^VALM("PXCE SDAM VIEW ONLY")
End DoDot:3
+26 IF '$TEST
DO EN^VALM("PXCE VIEW ONLY")
End DoDot:2
+27 IF '$TEST
IF PXCEVIEW["A"
Begin DoDot:2
+28 DO EN^VALM("PXCE SDAM MENU")
End DoDot:2
+29 IF '$TEST
DO EN^VALM("PXCE MAIN MENU")
End DoDot:1
if $DATA(PXCEVIEW)'=1!'$DATA(PXCECONT)
QUIT
+30 DO FULL^VALM1
+31 DO EXITALL
+32 QUIT
+33 ;
SETUP ;
+1 NEW DIR,DA,X,Y,PXRES
+2 NEW PXCEUSEL,X1,X2
+3 IF $GET(DFN)>0
SET PXCEUSEL=DFN_"^DPT("
+4 IF '$TEST
SET DIR(0)="815,201"
SET DIR("A")="Select Patient or Clinic name"
DO ^DIR
KILL DIR,DA
if $DATA(DIRUT)
QUIT
SET PXCEUSEL=Y
+5 SET X1=DT
SET X2=$SELECT($PIECE(^PX(815,1,"LM"),"^",3)]"":$PIECE(^PX(815,1,"LM"),"^",3),1:-30)
DO C^%DTC
+6 SET PXCEDBP=X
+7 SET X1=DT
SET X2=$SELECT($PIECE(^PX(815,1,"LM"),"^",4)]"":$PIECE(^PX(815,1,"LM"),"^",4),1:0)
DO C^%DTC
+8 SET PXCEDEP=X
+9 SET X1=DT
SET X2=$SELECT($PIECE(^PX(815,1,"LM"),"^",5)]"":$PIECE(^PX(815,1,"LM"),"^",5),1:-7)
DO C^%DTC
+10 SET PXCEDBHL=X
+11 SET X1=DT
SET X2=$SELECT($PIECE(^PX(815,1,"LM"),"^",6)]"":$PIECE(^PX(815,1,"LM"),"^",6),1:0)
DO C^%DTC
+12 SET PXCEDEHL=X
+13 IF PXCEUSEL["DPT("
SET $PIECE(PXCEVIEW,"^",1)="P"
SET SDAMTYP="P"
+14 IF PXCEUSEL["SC("
SET $PIECE(PXCEVIEW,"^",1)="H"
SET SDAMTYP="C"
Begin DoDot:1
+15 SET PXRES=$$CLNCK^SDUTL2(+PXCEUSEL,1)
+16 IF 'PXRES
WRITE !,?5,"Clinic MUST be corrected before continuing."
End DoDot:1
IF 'PXRES
GOTO SETUP
+17 DO SETDATES
+18 IF PXCEUSEL["DPT("
SET PXCEPAT=+PXCEUSEL
SET FSEL=1
DO NEWPAT1^PXCEPAT
KILL FSEL
if $DATA(DIRUT)
GOTO SETUP
+19 IF PXCEUSEL["SC("
SET PXCEHLOC=+PXCEUSEL
DO NEWHOSL1^PXCENEW
+20 QUIT
+21 ;
SETDATES ;
+1 IF PXCEVIEW["H"
Begin DoDot:1
+2 SET PXCEDBEG=PXCEDBHL
+3 SET PXCEDEND=PXCEDEHL
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET PXCEDBEG=PXCEDBP
+6 SET PXCEDEND=PXCEDEP
End DoDot:1
+7 DO DATE9S^PXCEDATE
+8 QUIT
+9 ;
HDR ; -- header code
+1 KILL VALMHDR,PXLNX,PXPCP
+2 SET PXLNX=1
SET PXPCP=""
+3 ;
+4 ;PATIENT
+5 IF PXCEVIEW["P"
Begin DoDot:1
+6 SET PXPCP=$$PCLINE^SDPPTEM(PXCEPAT,DT)
+7 SET VALMHDR(PXLNX)=$EXTRACT(PXCEPAT("NAME"),1,26)
+8 SET VALMHDR(PXLNX)=$EXTRACT(VALMHDR(PXLNX)_$EXTRACT(" ",1,(27-$LENGTH(VALMHDR(PXLNX))))_PXCEPAT("SSN")_" ",1,40)
End DoDot:1
+9 IF '$TEST
SET VALMHDR(PXLNX)=" "
+10 ;LOCATION
+11 SET VALMHDR(PXLNX)=VALMHDR(PXLNX)_"Clinic: "_$SELECT($GET(PXCEHLOC)&(PXCEVIEW'["P^A"):$PIECE(^SC(PXCEHLOC,0),"^"),1:"All")
+12 SET PXLNX=PXLNX+1
+13 IF $LENGTH(PXPCP)
SET VALMHDR(PXLNX)=PXPCP
SET PXLNX=PXLNX+1
+14 ;
+15 ;DATE
+16 SET VALMHDR(PXLNX)=$EXTRACT("Date range: "_$$FMTE^XLFDT(PXCEDBEG,5)_" to "_$$FMTE^XLFDT(PXCEDEND,5)_$JUSTIFY("",40),1,40)
+17 ;
+18 ;Credit Stop
+19 if PXCEVIEW["A"
SET VALMHDR(PXLNX)=VALMHDR(PXLNX)_$PIECE($GET(SDAMLIST),"^",2)
+20 SET PXLNX=PXLNX+1
+21 ;
+22 ;CHECK IF GAF NEEDED
+23 IF PXCEVIEW'["P"
IF $$MHCLIN^SDUTL2(PXCEHLOC)
SET VALMHDR(PXLNX)=$$SETSTR^VALM1("* - New GAF Score Required","",25,80)
+24 IF PXCEVIEW["P"
Begin DoDot:1
+25 SET VALMHDR(PXLNX)=$$SETSTR^VALM1("* - New GAF Score Required","",25,80)
+26 NEW PXCEHLC,PXCESTA
+27 KILL PXCEHIT
+28 SET PXCESTA=$$ELSTAT^SDUTL2(PXCEPAT)
+29 SET PXCEZZ=0
+30 FOR
SET PXCEZZ=$ORDER(^TMP("PXCEIDX",$JOB,PXCEZZ))
if PXCEZZ'>0
QUIT
Begin DoDot:2
+31 SET PXCEHLC=+$PIECE($GET(^AUPNVSIT(^TMP("PXCEIDX",$JOB,PXCEZZ),0)),"^",22)
+32 IF $$MHCLIN^SDUTL2(PXCEHLC)
IF '$$COLLAT^SDUTL2(PXCESTA)
Begin DoDot:3
+33 SET PXCEGAF=$$NEWGAF^SDUTL2($SELECT($DATA(SDFN):SDFN,$DATA(PXCEPAT):PXCEPAT,1:""))
+34 SET PXCEGST=$PIECE(PXCEGAF,"^")
+35 IF PXCEGST
Begin DoDot:4
+36 SET PXCEGDT=$$FMTE^XLFDT($PIECE(PXCEGAF,"^",3),"5M")
SET PXCEGSC=$PIECE(PXCEGAF,"^",2)
SET PXCEGPR=$PIECE(PXCEGAF,"^",4)
+37 SET VALMHDR(PXLNX)="GAF Date: "_PXCEGDT_" GAF Score:"_PXCEGSC_" NEW REQ"
SET PXCEHIT=1
End DoDot:4
End DoDot:3
End DoDot:2
if $DATA(PXCEHIT)
QUIT
End DoDot:1
+38 ;
+39 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+40 QUIT
+41 ;
INIT ; -- init variables and list array
+1 DO MAKELIST^PXCENEW
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO FULL^VALM1
+2 DO CLEAN^VALM10
+3 KILL ^TMP("PXCE",$JOB)
+4 KILL ^TMP("PXCEIDX",$JOB)
+5 DO FNL^PXCESDAM
+6 QUIT
+7 ;
EXITALL ; Exit of whole program
+1 DO PATKILL^PXCEPAT
+2 DO KVA^VADPT
+3 QUIT
+4 ;
DONE ; -- exit action for protocol
+1 if '$DATA(VALMBCK)
SET VALMBCK="R"
+2 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 DO EN^PXCEEXP
+2 QUIT
+3 ;
SEL1(HELP,PXCEADD) ; Select 1 visit
+1 ; If the $GET(PXCEADD) is non zero then will
+2 ; add to the prompt "add a new encounter"
+3 NEW X,Y,MAX
+4 SET MAX=+$GET(^TMP("PXCEIDX",$JOB,0))
IF MAX'>0
QUIT "^"
+5 SET Y=$PIECE($PIECE(XQORNOD(0),"^",4),"=",2)
+6 IF Y]""
Begin DoDot:1
+7 IF (+Y'=Y)!(+Y>MAX)!(+Y<1)!(Y#1'=0)
Begin DoDot:2
+8 WRITE !,$CHAR(7),"Selection '",Y,"' is not a valid choice."
+9 DO PAUSE^PXCEHELP
+10 SET Y="^"
End DoDot:2
End DoDot:1
+11 IF '$TEST
IF '$GET(PXCEADD)
Begin DoDot:1
+12 NEW DIR,DA
+13 SET DIR(0)="NAO^1:"_MAX_":0"
SET DIR("A")="Select Encounter"
+14 if MAX>1
SET DIR("A")=DIR("A")_" (1-"_MAX_"): "
+15 if MAX'>1
SET DIR("A")=DIR("A")_": "
SET DIR("B")=1
+16 SET DIR("?")="Enter the number of the Encounter you wish to "
+17 SET DIR("?")=DIR("?")_$SELECT($LENGTH(HELP):HELP,1:"act on")
+18 DO ^DIR
IF $DATA(DTOUT)!(X="")
SET Y="^"
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 NEW DIR,DA
ASKLOOP SET DIR(0)="FAO^1:"_$LENGTH(MAX)
+1 SET DIR("A")="Enter 1-"_MAX_" to Edit, or 'A' to Add: "
+2 SET DIR("?")="Enter the number of the Encounter you wish "
+3 SET DIR("?")=DIR("?")_$SELECT($LENGTH(HELP):HELP,1:"act on")_" or A to "
+4 SET DIR("?")=DIR("?")_$SELECT($LENGTH(HELP):HELP,1:"act on")_" add a new Encounter"
+5 DO ^DIR
+6 KILL DIR,DA
+7 IF $DATA(DIRUT)!(X="")
SET Y="^"
QUIT
+8 IF "Aa"[Y
SET Y="A"
QUIT
+9 if Y<1!(Y>MAX)
GOTO ASKLOOP
End DoDot:1
+10 QUIT Y
+11 ;
GAF ;;
+1 NEW PXCEVIEN,PXDFN,PXDSS,PXELIG,PXDATA
+2 IF $GET(PXCEHLOC)
IF '$$MHCLIN^SDUTL2(PXCEHLOC)
Begin DoDot:1
+3 SET DIR(0)="FOA"
+4 SET DIR("A",1)=" This is not a Mental Health Clinic, a GAF Score may not be entered."
+5 SET DIR("A")=" Press any key to continue: "
+6 DO ^DIR
KILL DIR
End DoDot:1
GOTO SKIP
+7 ;
+8 IF $DATA(^TMP("PXCEIDX",$JOB))
DO GETVIEN^PXCEAE
+9 IF $DATA(^TMP("SDAMIDX",$JOB))
SET PXCEVIEN=$$SELAPPM^PXCESDAM
+10 IF '($GET(PXCEVIEN)]"")!($GET(PXCEVIEN)=-1)
Begin DoDot:1
+11 SET DIR(0)="FAO"
+12 IF '($GET(PXCEVIEN)]"")
SET DIR("A",1)="Nothing to select."
+13 IF $GET(PXCEVIEN)=-1
SET DIR("A",1)="No selections made."
+14 SET DIR("A")="Press any key to continue."
+15 DO ^DIR
KILL DIR
End DoDot:1
SET VALMBCK="R"
QUIT
+16 SET PXDFN=$PIECE($GET(^AUPNVSIT(PXCEVIEN,0)),"^",5)
+17 SET PXDSS=$PIECE($GET(^AUPNVSIT(PXCEVIEN,0)),"^",8)
+18 SET PXDATA=$GET(^DPT(PXDFN,"S",$PIECE(^AUPNVSIT(PXCEVIEN,0),U),0))
+19 SET PXELIG=$$ELSTAT^SDUTL2(PXDFN)
+20 IF $$MHCLIN^SDUTL2("",PXDSS)
IF '($$COLLAT^SDUTL2(PXELIG)!$PIECE(PXDATA,U,11))
Begin DoDot:1
+21 SET PXGAF=$$NEWGAF^SDUTL2(PXDFN)
+22 DO FULL^VALM1
+23 WRITE !
+24 IF +$PIECE(PXGAF,U,5)>0
WRITE !,"Warning: Patient is deceased."
+25 WRITE !,"Current GAF: "_+$PIECE(PXGAF,U,2)
+26 WRITE $SELECT($PIECE(PXGAF,U,3)>0:", from "_$$FMTE^XLFDT($PIECE(PXGAF,U,3),"D"),1:", Date Unavailable")
+27 DO EN^SDGAF(PXDFN)
End DoDot:1
+28 IF '$TEST
Begin DoDot:1
+29 SET DIR(0)="FOA"
+30 SET DIR("A",1)="A GAF Score is not required for this appointment!"
+31 SET DIR("A")="Press any key to continue: "
+32 DO ^DIR
KILL DIR
End DoDot:1
+33 ;
SKIP SET VALMBCK="R"
GAFQ QUIT
+1 ;
