- 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 Jan 18, 2025@03:28:49 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 ;