PXCEVFI2 ;ISL/DEE,ESW - Supporting routines for editing a visit or v-file entry ;Jun 19, 2018@15:13
;;1.0;PCE PATIENT CARE ENCOUNTER;**22,73,95,96,124,158,184,215,211,217,235**;Aug 12, 1996;Build 25
; Reference to EN^DGREGEEWS in ICR #7208
; Reference to KILL^VSITKIL in ICR #1909
; Reference to ^SCE("AVSIT") in ICR #2045
; Reference to ^DIC(31) in ICR #792
; Reference to ^DIC(8) in ICR #602
; Reference to ^DIC(391) in ICR #1112
;
Q
ASK(PXCVIEN,PXCFIEN,PXCEAUPN,PXCCATT,PXCCODE) ; -- Display a selection list from one V-File for this visit
N PXCEINDX,PXCECNT,PXCEASK,PXCEREF,PXCEDT
N DIR,DA,X,Y
S PXCEINDX=""
F PXCECNT=0:1 S PXCEINDX=$O(@(PXCEAUPN_"(""AD"",PXCVIEN,PXCEINDX)")) Q:'PXCEINDX D
. I PXCECNT=0&(PXCCATT="Diagnosis") D SC($P(^AUPNVSIT(PXCEVIEN,0),U,5))
. I PXCECNT=0&(PXCCATT="CPT") D SC($P(^AUPNVSIT(PXCEVIEN,0),U,5))
. W:PXCECNT=0 !!,"--- "_PXCCATT_" ---",!
. S PXCEASK(PXCECNT+1)=PXCEINDX
. S PXCEDT=$P($G(@(PXCEAUPN_"(PXCEINDX,12)")),U,1)
. I PXCEDT="" S PXCEDT=$P(^AUPNVSIT(PXCEVIEN,0),U,1)
. W !,$J(PXCECNT+1,3),?6,@("$$DISPLY01^"_PXCCODE_"("_PXCEAUPN_"(PXCEINDX,0),PXCEDT)")
Q:PXCECNT'>0
ASKLOOP S DIR(0)="FAO^1:"_$L(PXCECNT)
I PXCECAT="IMM" D
. S DIR("A",1)="Enter 1-"_PXCECNT_" to Edit, 'A' to Add, or"
. S DIR("A")=" 'C' to document a Contraindication/Refusal: "
. S DIR("?",1)="Enter the number of the "_PXCCATT_" you wish to edit, A to add a"
. S DIR("?")="new "_PXCCATT_", or 'C' to document a Contraindication/Refusal."
E D
. S DIR("A")="Enter 1-"_PXCECNT_" to Edit, or 'A' to Add: "
. S DIR("?")="Enter the number of the "_PXCCATT_" you wish to edit or A to add a new "_PXCCATT_"."
D ^DIR
K DIR,DA
I $D(DIRUT) S PXCEQUIT=1 Q
Q:"Aa"[Y
I "Cc"[Y S PXVICR=1 Q
G:Y<1!(Y>PXCECNT) ASKLOOP
G:$G(PXCEASK(Y))'>0 ASKLOOP
S PXCFIEN=$G(PXCEASK(Y))
Q
;
SAVE ; -- Save this edited and quit editing.
I PXCECAT="CSTP" S PXCEFIEN=$$STOPCODE^PXUTLSTP(PXCESOR,$P(PXCEAFTR(0),"^",8),PXCEVIEN)
E D
. N PXCENODS,PXCEFOR,PXCENODE,PXCESEQ
. S PXCENODS=$P($T(FORMAT^@PXCECODE),"~",3)
. F PXCEFOR=1:1 S PXCENODE=$P(PXCENODS,",",PXCEFOR) Q:PXCENODE']"" D
.. I PXCENODE=1,PXCECATS="CPT" D Q
... S PXCESEQ=""
... F S PXCESEQ=$O(PXCEAFTR(PXCENODE,PXCESEQ)) Q:PXCESEQ="" D
.... S ^TMP("PXK",$J,PXCECATS,1,PXCENODE,PXCESEQ,"AFTER")=PXCEAFTR(PXCENODE,PXCESEQ)
.. S ^TMP("PXK",$J,PXCECATS,1,PXCENODE,"AFTER")=PXCEAFTR(PXCENODE)
. I PXCECAT="SK",$G(^TMP("PXK",$J,PXCECATS,1,"IEN"))]"" D SAVE^PXCESK
. D EN1^PXKMAIN
. I PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST") S PXCEVIEN=^TMP("PXK",$J,"VST",1,"IEN")
Q
;
DEL(PXCECAT) ; -- Delete this V-File entry from the List if all the visit information.
I PXCEFIEN'>0!(PXCEVIEN'>0) W !!,$C(7),"Error: Cannot delete this an unknown V-File entry." D PAUSE^PXCEHELP Q
I PXCEKEYS'["D",PXCEKEYS'["d" W !!,$C(7),"Error: You do not have delete access." D PAUSE^PXCEHELP Q
;
N PXCENODS,PXCEFOR,PXCENODE,PXCECATS,PXCECATT,PXCECODE,PXCEAUPN,PXCEQUIT
N PXCEDT
;
; Check to see if there is a skin test placement linked to this entry
I PXCECAT="SK",'$$CANDEL^PXCESK(PXCEFIEN) Q
;
S PXCECODE="PXCE"_$S(PXCECAT="IMM":"VIMM",1:PXCECAT)
S PXCECATS=$S(PXCECAT="CSTP":"VST",PXCECAT="HIST":"VST",1:PXCECAT)
S PXCEAUPN=$P($T(FORMAT^@PXCECODE),"~",5)
S PXCECATT=$P($P($T(FORMAT^@PXCECODE),";;",2),"~",1)
;
I '$D(@(PXCEAUPN_"(PXCEFIEN)")) Q
S PXCEDT=$P($G(@(PXCEAUPN_"(PXCEFIEN,12)")),U,1)
I PXCEDT="" S PXCEDT=$P(^AUPNVSIT(PXCEVIEN,0),U,1)
I $P($G(@(PXCEAUPN_"(PXCEFIEN,812)")),"^",1) D Q
. W !!,"Error on deleting "_PXCECATT_" ",@("$$DISPLY01^"_PXCECODE_"(@(PXCEAUPN_""(PXCEFIEN,0)""),PXCEDT)")
. W !,"Error: You cannot delete this entry it has been ""Verified""." D WAIT^PXCEHELP
I PXCEKEYS'["D" D Q:PXCEQUIT
. N PXCECHK
. S PXCEQUIT=0
. I PXCECATS="VST" S PXCECHK=$P($G(@(PXCEAUPN_"(PXCEFIEN,0)")),"^",23)
. E S PXCECHK=$P($P($P($G(@(PXCEAUPN_"(PXCEFIEN,801)")),"^",2),";",1)," ",2)
. I DUZ'=PXCECHK D
.. S PXCEQUIT=1
.. N NODE0
.. S NODE0=@(PXCEAUPN_"(PXCEFIEN,0)")
.. W !!,"Error on deleting "_PXCECATT_" ",@("$$DISPLY01^"_PXCECODE_"(NODE0,PXCEDT)")
.. W !,"Error: You cannot delete an entry you did not create." D WAIT^PXCEHELP
;
I PXCECAT="CSTP" D
. W !!,"Deleting "_PXCECATT_" "
. W @("$$DISPLY01^"_PXCECODE_"($G(@(PXCEAUPN_""(PXCEFIEN,0)"")),PXCEDT)")
. Q:'$$SURE^PXCEAE2
. N PXCERESU
. S PXCERESU=$$STOPCODE^PXUTLSTP(PXCESOR,"@",PXCEVIEN,PXCEFIEN)
. S:$D(PXCELOOP) PXCELOOP=1
E I PXCECATS="VST" D
. W !!,"Deleting "_PXCECATT_" "
. W @("$$DISPLY01^"_PXCECODE_"($G(@(PXCEAUPN_""(PXCEFIEN,0)"")),PXCEDT)")
. Q:'$$SURE^PXCEAE2
. N PXCERESU
. S PXCERESU=$$KILL^VSITKIL(PXCEVIEN)
. I PXCERESU D
.. I PXCERESU=1,$O(^SCE("AVSIT",PXCEVIEN,"")) Q
.. W !,$C(7),"Could not delete the encounter. There are still users of it." D WAIT^PXCEHELP
. I 'PXCERESU S PXCEVDEL=1 S:$D(PXCELOOP) (PXCELOOP,PXCEQUIT,PXCENOER)=1
. D EVENT^PXKMAIN
;
E D
. K ^TMP("PXK",$J)
. S ^TMP("PXK",$J,"VST",1,"IEN")=PXCEVIEN
. F PXCENODE=0,21,150,800,811,812 D
.. S (^TMP("PXK",$J,"VST",1,PXCENODE,"AFTER"),^TMP("PXK",$J,"VST",1,PXCENODE,"BEFORE"))=$G(^AUPNVSIT(PXCEVIEN,PXCENODE))
. ;
. S ^TMP("PXK",$J,"SOR")=PXCESOR
. S ^TMP("PXK",$J,PXCECATS,1,"IEN")=PXCEFIEN
. ;
. S PXCENODS=$P($T(FORMAT^@PXCECODE),"~",3)
. F PXCEFOR=1:1 S PXCENODE=$P(PXCENODS,",",PXCEFOR) Q:PXCENODE']"" D
.. S ^TMP("PXK",$J,PXCECATS,1,PXCENODE,"BEFORE")=$G(@(PXCEAUPN_"(PXCEFIEN,PXCENODE)"))
. ;
. N DIK,DA
. W !!,"Deleting "_PXCECATT_" "
. W @("$$DISPLY01^"_PXCECODE_"(^TMP(""PXK"",$J,PXCECATS,1,0,""BEFORE""),PXCEDT)")
. Q:'$$SURE^PXCEAE2 ;DELQUIT
. S PXCENODS=$P($T(FORMAT^@PXCECODE),"~",3)
. F PXCEFOR=1:1 S PXCENODE=$P(PXCENODS,",",PXCEFOR) Q:PXCENODE']"" S ^TMP("PXK",$J,PXCECATS,1,PXCENODE,"AFTER")=$S(PXCENODE=0:"@",1:"")
. D EN1^PXKMAIN
. S:$D(PXCELOOP) PXCELOOP=1
. I $D(PXCENOER)#2 S PXCENOER=1
;
DELQUIT ;
K ^TMP("PXK",$J)
Q
;
SC(PXDFN) ;Service Connected Help
; Input -- DFN Patient file IEN
; Output -- Help
N I,SDCNT,SDDC,SDRD0,ELIG,DGKEY,DGREQNAME,DGRESP,DGCOMP,ELIGSEQ
S ELIG="UNDETERMINED",(DGCOMP,DGKEY,DGREQNAME,DGRESP,ELIGSEQ)=""
;make call to determine patient eligibility
S DGKEY=$$GETICN^MPIF001(PXDFN),DGREQNAME="VistADataVTwo"
I $P(DGKEY,"^",1)'=-1 S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,"","",.DGCOMP)
;if it returns zero, check PATIENT file for Compact Act eligible code
I $P(DGRESP,"^",1)=0 D
. S ELIGSEQ=""
. F S ELIGSEQ=$O(^DPT(PXDFN,"E",ELIGSEQ)) Q:(ELIGSEQ="")!(ELIGSEQ="B")!(ELIG="ELIGIBLE") D
. . I $P($G(^DIC(8,ELIGSEQ,0)),"^",1)="COMPACT ACT ELIGIBLE" S ELIG="ELIGIBLE"
. . Q
. Q
I $P(DGRESP,"^",1)=1 D
. I DGCOMP="No" S ELIG="NOT ELIGIBLE"
. I DGCOMP="Yes" S ELIG="ELIGIBLE"
W !!,"COMPACT Act Administrative Eligibility:"
W !," COMPACT Act: ",ELIG
W !!,"Patient's Service Connection and Rated Disabilities:"
W !!,$S($P($G(^DPT(PXDFN,.3)),"^")="Y":" SC Percent: "_$P(^(.3),"^",2)_"%",1:" Service Connected: No")
W !,"Rated Disabilities: "
I $P($G(^DPT(PXDFN,"VET")),"^")'="Y",$S('$D(^DIC(391,+$G(^DPT(PXDFN,"TYPE")),0)):1,$P(^(0),"^",2):0,1:1) W "Not a Veteran" Q
S (SDCNT,I)=0
F S I=$O(^DPT(PXDFN,.372,I)) Q:'I I $P($G(^(I,0)),"^",3) S SDRD0=^(0) D
.S SDCNT=SDCNT+1
.S SDDC=$S('$D(^DIC(31,+SDRD0,0)):"",$P(^(0),"^",4)]"":$P(^(0),"^",4),1:$P(^(0),"^"))
.W:SDCNT>1 !
.W ?20,$P($G(^DIC(31,+SDRD0,0)),"^",3),?25,SDDC," (",$P(SDRD0,"^",2),"%-",$S($P(SDRD0,"^",3):"SC",1:""),")"
I 'SDCNT W $S('$O(^DPT(PXDFN,.372,0)):"None Stated",1:"No Service Connected Disabilities Listed")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEVFI2 7644 printed Oct 16, 2024@18:29:02 Page 2
PXCEVFI2 ;ISL/DEE,ESW - Supporting routines for editing a visit or v-file entry ;Jun 19, 2018@15:13
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**22,73,95,96,124,158,184,215,211,217,235**;Aug 12, 1996;Build 25
+2 ; Reference to EN^DGREGEEWS in ICR #7208
+3 ; Reference to KILL^VSITKIL in ICR #1909
+4 ; Reference to ^SCE("AVSIT") in ICR #2045
+5 ; Reference to ^DIC(31) in ICR #792
+6 ; Reference to ^DIC(8) in ICR #602
+7 ; Reference to ^DIC(391) in ICR #1112
+8 ;
+9 QUIT
ASK(PXCVIEN,PXCFIEN,PXCEAUPN,PXCCATT,PXCCODE) ; -- Display a selection list from one V-File for this visit
+1 NEW PXCEINDX,PXCECNT,PXCEASK,PXCEREF,PXCEDT
+2 NEW DIR,DA,X,Y
+3 SET PXCEINDX=""
+4 FOR PXCECNT=0:1
SET PXCEINDX=$ORDER(@(PXCEAUPN_"(""AD"",PXCVIEN,PXCEINDX)"))
if 'PXCEINDX
QUIT
Begin DoDot:1
+5 IF PXCECNT=0&(PXCCATT="Diagnosis")
DO SC($PIECE(^AUPNVSIT(PXCEVIEN,0),U,5))
+6 IF PXCECNT=0&(PXCCATT="CPT")
DO SC($PIECE(^AUPNVSIT(PXCEVIEN,0),U,5))
+7 if PXCECNT=0
WRITE !!,"--- "_PXCCATT_" ---",!
+8 SET PXCEASK(PXCECNT+1)=PXCEINDX
+9 SET PXCEDT=$PIECE($GET(@(PXCEAUPN_"(PXCEINDX,12)")),U,1)
+10 IF PXCEDT=""
SET PXCEDT=$PIECE(^AUPNVSIT(PXCEVIEN,0),U,1)
+11 WRITE !,$JUSTIFY(PXCECNT+1,3),?6,@("$$DISPLY01^"_PXCCODE_"("_PXCEAUPN_"(PXCEINDX,0),PXCEDT)")
End DoDot:1
+12 if PXCECNT'>0
QUIT
ASKLOOP SET DIR(0)="FAO^1:"_$LENGTH(PXCECNT)
+1 IF PXCECAT="IMM"
Begin DoDot:1
+2 SET DIR("A",1)="Enter 1-"_PXCECNT_" to Edit, 'A' to Add, or"
+3 SET DIR("A")=" 'C' to document a Contraindication/Refusal: "
+4 SET DIR("?",1)="Enter the number of the "_PXCCATT_" you wish to edit, A to add a"
+5 SET DIR("?")="new "_PXCCATT_", or 'C' to document a Contraindication/Refusal."
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET DIR("A")="Enter 1-"_PXCECNT_" to Edit, or 'A' to Add: "
+8 SET DIR("?")="Enter the number of the "_PXCCATT_" you wish to edit or A to add a new "_PXCCATT_"."
End DoDot:1
+9 DO ^DIR
+10 KILL DIR,DA
+11 IF $DATA(DIRUT)
SET PXCEQUIT=1
QUIT
+12 if "Aa"[Y
QUIT
+13 IF "Cc"[Y
SET PXVICR=1
QUIT
+14 if Y<1!(Y>PXCECNT)
GOTO ASKLOOP
+15 if $GET(PXCEASK(Y))'>0
GOTO ASKLOOP
+16 SET PXCFIEN=$GET(PXCEASK(Y))
+17 QUIT
+18 ;
SAVE ; -- Save this edited and quit editing.
+1 IF PXCECAT="CSTP"
SET PXCEFIEN=$$STOPCODE^PXUTLSTP(PXCESOR,$PIECE(PXCEAFTR(0),"^",8),PXCEVIEN)
+2 IF '$TEST
Begin DoDot:1
+3 NEW PXCENODS,PXCEFOR,PXCENODE,PXCESEQ
+4 SET PXCENODS=$PIECE($TEXT(FORMAT^@PXCECODE),"~",3)
+5 FOR PXCEFOR=1:1
SET PXCENODE=$PIECE(PXCENODS,",",PXCEFOR)
if PXCENODE']""
QUIT
Begin DoDot:2
+6 IF PXCENODE=1
IF PXCECATS="CPT"
Begin DoDot:3
+7 SET PXCESEQ=""
+8 FOR
SET PXCESEQ=$ORDER(PXCEAFTR(PXCENODE,PXCESEQ))
if PXCESEQ=""
QUIT
Begin DoDot:4
+9 SET ^TMP("PXK",$JOB,PXCECATS,1,PXCENODE,PXCESEQ,"AFTER")=PXCEAFTR(PXCENODE,PXCESEQ)
End DoDot:4
End DoDot:3
QUIT
+10 SET ^TMP("PXK",$JOB,PXCECATS,1,PXCENODE,"AFTER")=PXCEAFTR(PXCENODE)
End DoDot:2
+11 IF PXCECAT="SK"
IF $GET(^TMP("PXK",$JOB,PXCECATS,1,"IEN"))]""
DO SAVE^PXCESK
+12 DO EN1^PXKMAIN
+13 IF PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")
SET PXCEVIEN=^TMP("PXK",$JOB,"VST",1,"IEN")
End DoDot:1
+14 QUIT
+15 ;
DEL(PXCECAT) ; -- Delete this V-File entry from the List if all the visit information.
+1 IF PXCEFIEN'>0!(PXCEVIEN'>0)
WRITE !!,$CHAR(7),"Error: Cannot delete this an unknown V-File entry."
DO PAUSE^PXCEHELP
QUIT
+2 IF PXCEKEYS'["D"
IF PXCEKEYS'["d"
WRITE !!,$CHAR(7),"Error: You do not have delete access."
DO PAUSE^PXCEHELP
QUIT
+3 ;
+4 NEW PXCENODS,PXCEFOR,PXCENODE,PXCECATS,PXCECATT,PXCECODE,PXCEAUPN,PXCEQUIT
+5 NEW PXCEDT
+6 ;
+7 ; Check to see if there is a skin test placement linked to this entry
+8 IF PXCECAT="SK"
IF '$$CANDEL^PXCESK(PXCEFIEN)
QUIT
+9 ;
+10 SET PXCECODE="PXCE"_$SELECT(PXCECAT="IMM":"VIMM",1:PXCECAT)
+11 SET PXCECATS=$SELECT(PXCECAT="CSTP":"VST",PXCECAT="HIST":"VST",1:PXCECAT)
+12 SET PXCEAUPN=$PIECE($TEXT(FORMAT^@PXCECODE),"~",5)
+13 SET PXCECATT=$PIECE($PIECE($TEXT(FORMAT^@PXCECODE),";;",2),"~",1)
+14 ;
+15 IF '$DATA(@(PXCEAUPN_"(PXCEFIEN)"))
QUIT
+16 SET PXCEDT=$PIECE($GET(@(PXCEAUPN_"(PXCEFIEN,12)")),U,1)
+17 IF PXCEDT=""
SET PXCEDT=$PIECE(^AUPNVSIT(PXCEVIEN,0),U,1)
+18 IF $PIECE($GET(@(PXCEAUPN_"(PXCEFIEN,812)")),"^",1)
Begin DoDot:1
+19 WRITE !!,"Error on deleting "_PXCECATT_" ",@("$$DISPLY01^"_PXCECODE_"(@(PXCEAUPN_""(PXCEFIEN,0)""),PXCEDT)")
+20 WRITE !,"Error: You cannot delete this entry it has been ""Verified""."
DO WAIT^PXCEHELP
End DoDot:1
QUIT
+21 IF PXCEKEYS'["D"
Begin DoDot:1
+22 NEW PXCECHK
+23 SET PXCEQUIT=0
+24 IF PXCECATS="VST"
SET PXCECHK=$PIECE($GET(@(PXCEAUPN_"(PXCEFIEN,0)")),"^",23)
+25 IF '$TEST
SET PXCECHK=$PIECE($PIECE($PIECE($GET(@(PXCEAUPN_"(PXCEFIEN,801)")),"^",2),";",1)," ",2)
+26 IF DUZ'=PXCECHK
Begin DoDot:2
+27 SET PXCEQUIT=1
+28 NEW NODE0
+29 SET NODE0=@(PXCEAUPN_"(PXCEFIEN,0)")
+30 WRITE !!,"Error on deleting "_PXCECATT_" ",@("$$DISPLY01^"_PXCECODE_"(NODE0,PXCEDT)")
+31 WRITE !,"Error: You cannot delete an entry you did not create."
DO WAIT^PXCEHELP
End DoDot:2
End DoDot:1
if PXCEQUIT
QUIT
+32 ;
+33 IF PXCECAT="CSTP"
Begin DoDot:1
+34 WRITE !!,"Deleting "_PXCECATT_" "
+35 WRITE @("$$DISPLY01^"_PXCECODE_"($G(@(PXCEAUPN_""(PXCEFIEN,0)"")),PXCEDT)")
+36 if '$$SURE^PXCEAE2
QUIT
+37 NEW PXCERESU
+38 SET PXCERESU=$$STOPCODE^PXUTLSTP(PXCESOR,"@",PXCEVIEN,PXCEFIEN)
+39 if $DATA(PXCELOOP)
SET PXCELOOP=1
End DoDot:1
+40 IF '$TEST
IF PXCECATS="VST"
Begin DoDot:1
+41 WRITE !!,"Deleting "_PXCECATT_" "
+42 WRITE @("$$DISPLY01^"_PXCECODE_"($G(@(PXCEAUPN_""(PXCEFIEN,0)"")),PXCEDT)")
+43 if '$$SURE^PXCEAE2
QUIT
+44 NEW PXCERESU
+45 SET PXCERESU=$$KILL^VSITKIL(PXCEVIEN)
+46 IF PXCERESU
Begin DoDot:2
+47 IF PXCERESU=1
IF $ORDER(^SCE("AVSIT",PXCEVIEN,""))
QUIT
+48 WRITE !,$CHAR(7),"Could not delete the encounter. There are still users of it."
DO WAIT^PXCEHELP
End DoDot:2
+49 IF 'PXCERESU
SET PXCEVDEL=1
if $DATA(PXCELOOP)
SET (PXCELOOP,PXCEQUIT,PXCENOER)=1
+50 DO EVENT^PXKMAIN
End DoDot:1
+51 ;
+52 IF '$TEST
Begin DoDot:1
+53 KILL ^TMP("PXK",$JOB)
+54 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=PXCEVIEN
+55 FOR PXCENODE=0,21,150,800,811,812
Begin DoDot:2
+56 SET (^TMP("PXK",$JOB,"VST",1,PXCENODE,"AFTER"),^TMP("PXK",$JOB,"VST",1,PXCENODE,"BEFORE"))=$GET(^AUPNVSIT(PXCEVIEN,PXCENODE))
End DoDot:2
+57 ;
+58 SET ^TMP("PXK",$JOB,"SOR")=PXCESOR
+59 SET ^TMP("PXK",$JOB,PXCECATS,1,"IEN")=PXCEFIEN
+60 ;
+61 SET PXCENODS=$PIECE($TEXT(FORMAT^@PXCECODE),"~",3)
+62 FOR PXCEFOR=1:1
SET PXCENODE=$PIECE(PXCENODS,",",PXCEFOR)
if PXCENODE']""
QUIT
Begin DoDot:2
+63 SET ^TMP("PXK",$JOB,PXCECATS,1,PXCENODE,"BEFORE")=$GET(@(PXCEAUPN_"(PXCEFIEN,PXCENODE)"))
End DoDot:2
+64 ;
+65 NEW DIK,DA
+66 WRITE !!,"Deleting "_PXCECATT_" "
+67 WRITE @("$$DISPLY01^"_PXCECODE_"(^TMP(""PXK"",$J,PXCECATS,1,0,""BEFORE""),PXCEDT)")
+68 ;DELQUIT
if '$$SURE^PXCEAE2
QUIT
+69 SET PXCENODS=$PIECE($TEXT(FORMAT^@PXCECODE),"~",3)
+70 FOR PXCEFOR=1:1
SET PXCENODE=$PIECE(PXCENODS,",",PXCEFOR)
if PXCENODE']""
QUIT
SET ^TMP("PXK",$JOB,PXCECATS,1,PXCENODE,"AFTER")=$SELECT(PXCENODE=0:"@",1:"")
+71 DO EN1^PXKMAIN
+72 if $DATA(PXCELOOP)
SET PXCELOOP=1
+73 IF $DATA(PXCENOER)#2
SET PXCENOER=1
End DoDot:1
+74 ;
DELQUIT ;
+1 KILL ^TMP("PXK",$JOB)
+2 QUIT
+3 ;
SC(PXDFN) ;Service Connected Help
+1 ; Input -- DFN Patient file IEN
+2 ; Output -- Help
+3 NEW I,SDCNT,SDDC,SDRD0,ELIG,DGKEY,DGREQNAME,DGRESP,DGCOMP,ELIGSEQ
+4 SET ELIG="UNDETERMINED"
SET (DGCOMP,DGKEY,DGREQNAME,DGRESP,ELIGSEQ)=""
+5 ;make call to determine patient eligibility
+6 SET DGKEY=$$GETICN^MPIF001(PXDFN)
SET DGREQNAME="VistADataVTwo"
+7 IF $PIECE(DGKEY,"^",1)'=-1
SET DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,"","",.DGCOMP)
+8 ;if it returns zero, check PATIENT file for Compact Act eligible code
+9 IF $PIECE(DGRESP,"^",1)=0
Begin DoDot:1
+10 SET ELIGSEQ=""
+11 FOR
SET ELIGSEQ=$ORDER(^DPT(PXDFN,"E",ELIGSEQ))
if (ELIGSEQ="")!(ELIGSEQ="B")!(ELIG="ELIGIBLE")
QUIT
Begin DoDot:2
+12 IF $PIECE($GET(^DIC(8,ELIGSEQ,0)),"^",1)="COMPACT ACT ELIGIBLE"
SET ELIG="ELIGIBLE"
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF $PIECE(DGRESP,"^",1)=1
Begin DoDot:1
+16 IF DGCOMP="No"
SET ELIG="NOT ELIGIBLE"
+17 IF DGCOMP="Yes"
SET ELIG="ELIGIBLE"
End DoDot:1
+18 WRITE !!,"COMPACT Act Administrative Eligibility:"
+19 WRITE !," COMPACT Act: ",ELIG
+20 WRITE !!,"Patient's Service Connection and Rated Disabilities:"
+21 WRITE !!,$SELECT($PIECE($GET(^DPT(PXDFN,.3)),"^")="Y":" SC Percent: "_$PIECE(^(.3),"^",2)_"%",1:" Service Connected: No")
+22 WRITE !,"Rated Disabilities: "
+23 IF $PIECE($GET(^DPT(PXDFN,"VET")),"^")'="Y"
IF $SELECT('$DATA(^DIC(391,+$GET(^DPT(PXDFN,"TYPE")),0)):1,$PIECE(^(0),"^",2):0,1:1)
WRITE "Not a Veteran"
QUIT
+24 SET (SDCNT,I)=0
+25 FOR
SET I=$ORDER(^DPT(PXDFN,.372,I))
if 'I
QUIT
IF $PIECE($GET(^(I,0)),"^",3)
SET SDRD0=^(0)
Begin DoDot:1
+26 SET SDCNT=SDCNT+1
+27 SET SDDC=$SELECT('$DATA(^DIC(31,+SDRD0,0)):"",$PIECE(^(0),"^",4)]"":$PIECE(^(0),"^",4),1:$PIECE(^(0),"^"))
+28 if SDCNT>1
WRITE !
+29 WRITE ?20,$PIECE($GET(^DIC(31,+SDRD0,0)),"^",3),?25,SDDC," (",$PIECE(SDRD0,"^",2),"%-",$SELECT($PIECE(SDRD0,"^",3):"SC",1:""),")"
End DoDot:1
+30 IF 'SDCNT
WRITE $SELECT('$ORDER(^DPT(PXDFN,.372,0)):"None Stated",1:"No Service Connected Disabilities Listed")
+31 ;
+32 QUIT
