SDACSCG ;ALB/TET - Print/Edit Computer Generated Appt Types ;3/18/92 14:18
;;5.3;Scheduling;**16,22,132,202,721**;Aug 13, 1993;Build 11
;
Q
CK ; -- check the number of computer generated visits
N SDT,SDOE,CT
S (SDT,CT)=0
F S SDT=$O(^SCE("ACG",SDT)) Q:'SDT D
. S SDOE=0
. F S SDOE=$O(^SCE("ACG",SDT,SDOE)) Q:'SDOE S CT=CT+1
;
I CT D
. W !?5,"There are ",CT," encounter(s) with a 'Computer Generated' appointment type.",*7,!
E D
. W !?5,"There are no 'Computer Generated' appointment type encounters."
Q
;
PRINT ;print those CG types which need to be manually updated
S DGPGM="QUE^SDACSCG"
D ZIS^DGUTQ
Q:POP
;
QUE ; -- queue entry point
N SDOE,SDOE0,SDT,DSAH,SDY,CT,Y,X,VA,VADM,VAERR,CT,%DT
S DASH="",$P(DASH,"-",79)=""
S (SDT,CT)=0,%DT="SX"
D HDR
F S SDT=$O(^SCE("ACG",SDT)) Q:'SDT D G:$D(DTOUT)!($D(DUOUT)) EXIT
. S Y=SDT D DD^%DT S SDY=Y
. S SDOE=0
. F S SDOE=$O(^SCE("ACG",SDT,SDOE)) Q:'SDOE D Q:$D(DTOUT)!($D(DUOUT))
. . S SDOE0=$G(^SCE(SDOE,0))
. . S DFN=+$P(SDOE0,U,2)
. . D DEM^VADPT
. . D:$Y+6>IOSL CR,HDR
. . Q:$D(DTOUT)!($D(DUOUT))
. . W !,SDY,?25,$S(VAERR=0:VADM(1),1:"UNKNOWN"),?60,$G(VA("PID")) ;SD*5.3*721 - Protect VA("PID") variable
. . S CT=CT+1
I CT D:$Y+4>IOSL CR W !!,CT," MATCHES FOUND.",!
;
EXIT ; -- exit processing
K %DT,CT,D,DA,DASH,DE,DFN,DFN0,DGPGM,DIC,DIE,DIRUT,DQ
K DR,DTOUT,DUOUT,FR,I,J,POP,SDA,SDAPTYP,SDBEG,SDCSNODE
K SDDIV,SDEND,SDUPDT,SDY,SDZN,SDTYPE,TO,VADM,VAEL,VAERR,VA,X,Y
Q
;
CR ; -- end of page processing
Q:$E(IOST,1,2)'="C-"
W !!,"Press RETURN to continue or '^' to exit: "
R SDXX:DTIME S:'$T DTOUT=1
Q:$D(DTOUT)!(SDXX="")
I SDXX="^" S DUOUT=1 Q
W !?5,"Enter an '^' to exit the listing, or enter RETURN to continue."
G CR
;
HDR ; -- header processing
W:$D(IOF) @IOF W !,"COMPUTER GENERATED APPOINTMENT TYPES"
W !,"ENCOUNTER DATE/TIME",?25,"PATIENT",?60,"PT ID",!,DASH,!!
Q
;
EDIT ; -- edit computer generated appt types
N DIR,SDOUT,%DT
I '$O(^SCE("ACG",0)) W !!?5,"There are no 'Computer Generated' Appointment Types which need updating." G EDITQ
;
W !
S DIR("A",1)="You may enter one of the following:"
S DIR("A",2)=" Encounter Date - edit 'Computer Generated' entries for a specific date"
S DIR("A",3)=" Patient Name (or SSN) - edit 'Computer Generated' entries for one patient"
S DIR("A",4)=" The default of 'ALL' - edit all entries which are 'Computer Generated'"
S DIR("A")="Select Encounter Date"
S DIR("B")="ALL"
S DIR(0)="F^1:30"
S %DT(0)="-DT"
S DIR("?")="^D QUE^SDACSCG"
D ^DIR K DIR
G:$D(DIRUT) EDITQ
;
S SDOUT=0
D
.N SDZ
.I "ALLall"[Y D Q
..D ALL
.S (X,SDZ)=Y,%DT="PX"
.D ^%DT
.I Y'=-1 D Q
..S Y=SDZ
..D DATE
.S Y=SDZ
.I Y?9N!(Y?1A4N)!(Y?.AP)!(Y?4N) D Q
..D DPT
;
I 'SDOUT G EDIT
;
EDITQ D EXIT
Q
;
DATE ;
N CT,%DT,Y,SDBEG,SDEND
S CT=0
S %DT="EPTXS"
S %DT(0)=-DT
D ^%DT S Y=+Y
IF $D(DTOUT) S SDOUT=1 G DATEQ
G DATEQ:Y=-1
;
S SDBEG=$S(Y[".":Y-.000001,1:Y)
S SDEND=$S(Y[".":Y,1:Y_.999999)
D LOOP(SDBEG,SDEND)
;
G:SDOUT DATEQ
W:'CT !,"There are no 'Computer Generated' appt types for selection.",*7,!
DATEQ Q
;
ALL ; -- loop through and edit all computer generated appt types
N CT
S CT=0
;
D LOOP()
;
ALLQ Q
;
DPT ; -- look up in patient file & loop through acg for selected dfn
;
N DIC,D,CT,Y
S CT=0
S DIC="^DPT(",DIC(0)="EQMZ"
S D=$S(X?9N:"SSN",X?1A.4N:"B5",1:"B")
D IX^DIC
G DPTQ:Y'>0
;
D LOOP(,,+Y)
;
G:SDOUT DPTQ
W:'CT !,"There are no 'Computer Generated' appt types for selected entry.",*7,!
DPTQ Q
;
LOOP(SDBEG,SDEND,SDFN) ;
N SDY,DFN,VA,VAERR,VAADM,SDT,SDOE,SDCLIN,SDSTOP,SDDIV,SDSTA,SDPAT,SDDT,SDCELIG
;
IF '$G(SDBEG) N SDBEG S SDBEG=0
IF '$G(SDEND) N SDEND S SDEND=9999999
IF '$G(SDFN) N SDFN S SDFN=0
;
S SDT=SDBEG
F S SDT=$O(^SCE("ACG",SDT)) Q:'SDT!(SDT>SDEND) D Q:SDOUT
. S SDOE=0
. F S SDOE=$O(^SCE("ACG",SDT,SDOE)) Q:'SDOE D Q:SDOUT
. . IF SDFN,SDFN'=+$P($G(^SCE(SDOE,0)),"^",2) Q
. . S SDPAT=+$P($G(^SCE(SDOE,0)),"^",2) Q:'SDPAT ;SD*721 - Quit if no patient info in encounter
. . S SDDT=$P(+$P($G(^SCE(SDOE,0)),U),".") Q:'SDDT ;SD*721 - Quit if not valid date
. . Q:$G(^DPT(SDPAT,0))="" ;SD*721 - Quit if not in Patient File, supported by ICR #10035
. . S SDCELIG=$$GET1^DIQ(409.68,SDOE,.13) ;SD*721 - Get Current Eligibility
. . S SDCLIN=$$GET1^DIQ(409.68,SDOE,.04),SDSTOP=$$GET1^DIQ(409.68,SDOE,.03)
. . ;Reference to SITE^VASITE supported by ICR #10112
. . S SDDIV=$$GET1^DIQ(409.68,SDOE,.11,"I"),SDSTA=$P($$SITE^VASITE(SDDT,SDDIV),U,3)
. . D DEM(SDOE),DEMW
. . D DIE(SDOE)
LOOPQ Q
;
DEM(SDOE) ; -- get pt name,ssn and visit date
N SDOE0,Y,DFN
S SDOE0=$G(^SCE(SDOE,0))
S DFN=+$P(SDOE0,"^",2)
D DEM^VADPT
S Y=+SDOE0 D DD^%DT S SDY=Y
Q
;
DEMW ; -- write patient demographics
;SD*721 - Add header, division, location, stop code, and service connected information
N SDHASH
W @IOF,"ENCOUNTER DATE",?25,"PATIENT NAME",?60,"PATIENT SSN" ;Header - SD*721
W !,?3,"DIVISION",?15,"CLINIC LOCATION",?50,"STOP CODE" ;Header - SD*721
W ! F SDHASH=1:1:80 W "-" ;Header - SD*721
W !,SDY,?25,$S(VAERR=0:VADM(1),1:"UNKNOWN"),?60,$G(VA("PID")) ;SD*5.3*721 - Protect VA("PID") variable
W !,?3,SDSTA,?15,$S(SDCLIN'="":SDCLIN,1:"UNKNOWN LOCATION"),?50,SDSTOP ;SD*721 - division, location, stop code
D SC(SDPAT) ;SD*721 - Service connected info
K VAEL,DFN
Q
;
DIE(SDOE) ; -- do edit
N DR,DIE,DE,DQ
S DR=".1d;I $P(^(0),U,10)=10 S Y=""@99"";202///@;@99"
S DIE="^SCE("
S DA=SDOE
D ^DIE
S:$D(DTOUT)!($D(Y)'=0) SDOUT=1
S CT=CT+1
Q
;
SC(DFN) ;SD*721 - Add Service Connected Information
; Input -- DFN Patient file IEN
N SDI,SDCNT,SDDC,SDRD0,SDARR,SDSECN
;Reference to ELIG^VADPT supported by ICR #10061
D ELIG^VADPT
W !!,"Patient's Service Connection and Rated Disabilities:"
W !!,$S(+VAEL(3)="1":" SC Percent: "_$P(VAEL(3),U,2)_"%",1:" Service Connected: No")
W !,"Rated Disabilities: "
I 'VAEL(4) W "Not a Veteran",!,"Primary Eligibility Code: ",$S(+VAEL(1):$P(VAEL(1),U,2),1:"N/A") D W !!,"Current Eligibility for Encounter: ",$S(SDCELIG'="":SDCELIG,1:"N/A") Q
.S SDSECN=0 F S SDSECN=$O(VAEL(1,SDSECN)) Q:'SDSECN W !,"Secondary Eligibility Code: ",$P(VAEL(1,SDSECN),U,2)
S (SDCNT,SDI)=0
;Reference to ^DPT(DFN,.372 supported by ICR #1476
F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI I $P($G(^(SDI,0)),"^",3) S SDRD0=^(0) D
.S SDCNT=SDCNT+1
.;Reference to ^DIC(31,+SDRD0 supported by ICR #733
.S SDDC=$P($G(^DIC(31,+SDRD0,0)),U)
.W:SDCNT>1 !
.W ?20,SDDC," (",$P(SDRD0,"^",2),"%-",$S($P(SDRD0,"^",3):"SC",1:""),")"
I 'SDCNT W $S('$O(^DPT(DFN,.372,0)):"None Stated",1:"No Service Connected Disabilities Listed")
W !,"Primary Eligibility Code: ",$S(+VAEL(1):$P(VAEL(1),U,2),1:"N/A") D
.S SDSECN=0 F S SDSECN=$O(VAEL(1,SDSECN)) Q:'SDSECN W !,"Secondary Eligibility Code: ",$P(VAEL(1,SDSECN),U,2)
W !!,"Current Eligibility for Encounter: ",$S(SDCELIG'="":SDCELIG,1:"N/A")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDACSCG 7065 printed Nov 22, 2024@17:56:56 Page 2
SDACSCG ;ALB/TET - Print/Edit Computer Generated Appt Types ;3/18/92 14:18
+1 ;;5.3;Scheduling;**16,22,132,202,721**;Aug 13, 1993;Build 11
+2 ;
+3 QUIT
CK ; -- check the number of computer generated visits
+1 NEW SDT,SDOE,CT
+2 SET (SDT,CT)=0
+3 FOR
SET SDT=$ORDER(^SCE("ACG",SDT))
if 'SDT
QUIT
Begin DoDot:1
+4 SET SDOE=0
+5 FOR
SET SDOE=$ORDER(^SCE("ACG",SDT,SDOE))
if 'SDOE
QUIT
SET CT=CT+1
End DoDot:1
+6 ;
+7 IF CT
Begin DoDot:1
+8 WRITE !?5,"There are ",CT," encounter(s) with a 'Computer Generated' appointment type.",*7,!
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 WRITE !?5,"There are no 'Computer Generated' appointment type encounters."
End DoDot:1
+11 QUIT
+12 ;
PRINT ;print those CG types which need to be manually updated
+1 SET DGPGM="QUE^SDACSCG"
+2 DO ZIS^DGUTQ
+3 if POP
QUIT
+4 ;
QUE ; -- queue entry point
+1 NEW SDOE,SDOE0,SDT,DSAH,SDY,CT,Y,X,VA,VADM,VAERR,CT,%DT
+2 SET DASH=""
SET $PIECE(DASH,"-",79)=""
+3 SET (SDT,CT)=0
SET %DT="SX"
+4 DO HDR
+5 FOR
SET SDT=$ORDER(^SCE("ACG",SDT))
if 'SDT
QUIT
Begin DoDot:1
+6 SET Y=SDT
DO DD^%DT
SET SDY=Y
+7 SET SDOE=0
+8 FOR
SET SDOE=$ORDER(^SCE("ACG",SDT,SDOE))
if 'SDOE
QUIT
Begin DoDot:2
+9 SET SDOE0=$GET(^SCE(SDOE,0))
+10 SET DFN=+$PIECE(SDOE0,U,2)
+11 DO DEM^VADPT
+12 if $Y+6>IOSL
DO CR
DO HDR
+13 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+14 ;SD*5.3*721 - Protect VA("PID") variable
WRITE !,SDY,?25,$SELECT(VAERR=0:VADM(1),1:"UNKNOWN"),?60,$GET(VA("PID"))
+15 SET CT=CT+1
End DoDot:2
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
+16 IF CT
if $Y+4>IOSL
DO CR
WRITE !!,CT," MATCHES FOUND.",!
+17 ;
EXIT ; -- exit processing
+1 KILL %DT,CT,D,DA,DASH,DE,DFN,DFN0,DGPGM,DIC,DIE,DIRUT,DQ
+2 KILL DR,DTOUT,DUOUT,FR,I,J,POP,SDA,SDAPTYP,SDBEG,SDCSNODE
+3 KILL SDDIV,SDEND,SDUPDT,SDY,SDZN,SDTYPE,TO,VADM,VAEL,VAERR,VA,X,Y
+4 QUIT
+5 ;
CR ; -- end of page processing
+1 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 WRITE !!,"Press RETURN to continue or '^' to exit: "
+3 READ SDXX:DTIME
if '$TEST
SET DTOUT=1
+4 if $DATA(DTOUT)!(SDXX="")
QUIT
+5 IF SDXX="^"
SET DUOUT=1
QUIT
+6 WRITE !?5,"Enter an '^' to exit the listing, or enter RETURN to continue."
+7 GOTO CR
+8 ;
HDR ; -- header processing
+1 if $DATA(IOF)
WRITE @IOF
WRITE !,"COMPUTER GENERATED APPOINTMENT TYPES"
+2 WRITE !,"ENCOUNTER DATE/TIME",?25,"PATIENT",?60,"PT ID",!,DASH,!!
+3 QUIT
+4 ;
EDIT ; -- edit computer generated appt types
+1 NEW DIR,SDOUT,%DT
+2 IF '$ORDER(^SCE("ACG",0))
WRITE !!?5,"There are no 'Computer Generated' Appointment Types which need updating."
GOTO EDITQ
+3 ;
+4 WRITE !
+5 SET DIR("A",1)="You may enter one of the following:"
+6 SET DIR("A",2)=" Encounter Date - edit 'Computer Generated' entries for a specific date"
+7 SET DIR("A",3)=" Patient Name (or SSN) - edit 'Computer Generated' entries for one patient"
+8 SET DIR("A",4)=" The default of 'ALL' - edit all entries which are 'Computer Generated'"
+9 SET DIR("A")="Select Encounter Date"
+10 SET DIR("B")="ALL"
+11 SET DIR(0)="F^1:30"
+12 SET %DT(0)="-DT"
+13 SET DIR("?")="^D QUE^SDACSCG"
+14 DO ^DIR
KILL DIR
+15 if $DATA(DIRUT)
GOTO EDITQ
+16 ;
+17 SET SDOUT=0
+18 Begin DoDot:1
+19 NEW SDZ
+20 IF "ALLall"[Y
Begin DoDot:2
+21 DO ALL
End DoDot:2
QUIT
+22 SET (X,SDZ)=Y
SET %DT="PX"
+23 DO ^%DT
+24 IF Y'=-1
Begin DoDot:2
+25 SET Y=SDZ
+26 DO DATE
End DoDot:2
QUIT
+27 SET Y=SDZ
+28 IF Y?9N!(Y?1A4N)!(Y?.AP)!(Y?4N)
Begin DoDot:2
+29 DO DPT
End DoDot:2
QUIT
End DoDot:1
+30 ;
+31 IF 'SDOUT
GOTO EDIT
+32 ;
EDITQ DO EXIT
+1 QUIT
+2 ;
DATE ;
+1 NEW CT,%DT,Y,SDBEG,SDEND
+2 SET CT=0
+3 SET %DT="EPTXS"
+4 SET %DT(0)=-DT
+5 DO ^%DT
SET Y=+Y
+6 IF $DATA(DTOUT)
SET SDOUT=1
GOTO DATEQ
+7 if Y=-1
GOTO DATEQ
+8 ;
+9 SET SDBEG=$SELECT(Y[".":Y-.000001,1:Y)
+10 SET SDEND=$SELECT(Y[".":Y,1:Y_.999999)
+11 DO LOOP(SDBEG,SDEND)
+12 ;
+13 if SDOUT
GOTO DATEQ
+14 if 'CT
WRITE !,"There are no 'Computer Generated' appt types for selection.",*7,!
DATEQ QUIT
+1 ;
ALL ; -- loop through and edit all computer generated appt types
+1 NEW CT
+2 SET CT=0
+3 ;
+4 DO LOOP()
+5 ;
ALLQ QUIT
+1 ;
DPT ; -- look up in patient file & loop through acg for selected dfn
+1 ;
+2 NEW DIC,D,CT,Y
+3 SET CT=0
+4 SET DIC="^DPT("
SET DIC(0)="EQMZ"
+5 SET D=$SELECT(X?9N:"SSN",X?1A.4N:"B5",1:"B")
+6 DO IX^DIC
+7 if Y'>0
GOTO DPTQ
+8 ;
+9 DO LOOP(,,+Y)
+10 ;
+11 if SDOUT
GOTO DPTQ
+12 if 'CT
WRITE !,"There are no 'Computer Generated' appt types for selected entry.",*7,!
DPTQ QUIT
+1 ;
LOOP(SDBEG,SDEND,SDFN) ;
+1 NEW SDY,DFN,VA,VAERR,VAADM,SDT,SDOE,SDCLIN,SDSTOP,SDDIV,SDSTA,SDPAT,SDDT,SDCELIG
+2 ;
+3 IF '$GET(SDBEG)
NEW SDBEG
SET SDBEG=0
+4 IF '$GET(SDEND)
NEW SDEND
SET SDEND=9999999
+5 IF '$GET(SDFN)
NEW SDFN
SET SDFN=0
+6 ;
+7 SET SDT=SDBEG
+8 FOR
SET SDT=$ORDER(^SCE("ACG",SDT))
if 'SDT!(SDT>SDEND)
QUIT
Begin DoDot:1
+9 SET SDOE=0
+10 FOR
SET SDOE=$ORDER(^SCE("ACG",SDT,SDOE))
if 'SDOE
QUIT
Begin DoDot:2
+11 IF SDFN
IF SDFN'=+$PIECE($GET(^SCE(SDOE,0)),"^",2)
QUIT
+12 ;SD*721 - Quit if no patient info in encounter
SET SDPAT=+$PIECE($GET(^SCE(SDOE,0)),"^",2)
if 'SDPAT
QUIT
+13 ;SD*721 - Quit if not valid date
SET SDDT=$PIECE(+$PIECE($GET(^SCE(SDOE,0)),U),".")
if 'SDDT
QUIT
+14 ;SD*721 - Quit if not in Patient File, supported by ICR #10035
if $GET(^DPT(SDPAT,0))=""
QUIT
+15 ;SD*721 - Get Current Eligibility
SET SDCELIG=$$GET1^DIQ(409.68,SDOE,.13)
+16 SET SDCLIN=$$GET1^DIQ(409.68,SDOE,.04)
SET SDSTOP=$$GET1^DIQ(409.68,SDOE,.03)
+17 ;Reference to SITE^VASITE supported by ICR #10112
+18 SET SDDIV=$$GET1^DIQ(409.68,SDOE,.11,"I")
SET SDSTA=$PIECE($$SITE^VASITE(SDDT,SDDIV),U,3)
+19 DO DEM(SDOE)
DO DEMW
+20 DO DIE(SDOE)
End DoDot:2
if SDOUT
QUIT
End DoDot:1
if SDOUT
QUIT
LOOPQ QUIT
+1 ;
DEM(SDOE) ; -- get pt name,ssn and visit date
+1 NEW SDOE0,Y,DFN
+2 SET SDOE0=$GET(^SCE(SDOE,0))
+3 SET DFN=+$PIECE(SDOE0,"^",2)
+4 DO DEM^VADPT
+5 SET Y=+SDOE0
DO DD^%DT
SET SDY=Y
+6 QUIT
+7 ;
DEMW ; -- write patient demographics
+1 ;SD*721 - Add header, division, location, stop code, and service connected information
+2 NEW SDHASH
+3 ;Header - SD*721
WRITE @IOF,"ENCOUNTER DATE",?25,"PATIENT NAME",?60,"PATIENT SSN"
+4 ;Header - SD*721
WRITE !,?3,"DIVISION",?15,"CLINIC LOCATION",?50,"STOP CODE"
+5 ;Header - SD*721
WRITE !
FOR SDHASH=1:1:80
WRITE "-"
+6 ;SD*5.3*721 - Protect VA("PID") variable
WRITE !,SDY,?25,$SELECT(VAERR=0:VADM(1),1:"UNKNOWN"),?60,$GET(VA("PID"))
+7 ;SD*721 - division, location, stop code
WRITE !,?3,SDSTA,?15,$SELECT(SDCLIN'="":SDCLIN,1:"UNKNOWN LOCATION"),?50,SDSTOP
+8 ;SD*721 - Service connected info
DO SC(SDPAT)
+9 KILL VAEL,DFN
+10 QUIT
+11 ;
DIE(SDOE) ; -- do edit
+1 NEW DR,DIE,DE,DQ
+2 SET DR=".1d;I $P(^(0),U,10)=10 S Y=""@99"";202///@;@99"
+3 SET DIE="^SCE("
+4 SET DA=SDOE
+5 DO ^DIE
+6 if $DATA(DTOUT)!($DATA(Y)'=0)
SET SDOUT=1
+7 SET CT=CT+1
+8 QUIT
+9 ;
SC(DFN) ;SD*721 - Add Service Connected Information
+1 ; Input -- DFN Patient file IEN
+2 NEW SDI,SDCNT,SDDC,SDRD0,SDARR,SDSECN
+3 ;Reference to ELIG^VADPT supported by ICR #10061
+4 DO ELIG^VADPT
+5 WRITE !!,"Patient's Service Connection and Rated Disabilities:"
+6 WRITE !!,$SELECT(+VAEL(3)="1":" SC Percent: "_$PIECE(VAEL(3),U,2)_"%",1:" Service Connected: No")
+7 WRITE !,"Rated Disabilities: "
+8 IF 'VAEL(4)
WRITE "Not a Veteran",!,"Primary Eligibility Code: ",$SELECT(+VAEL(1):$PIECE(VAEL(1),U,2),1:"N/A")
Begin DoDot:1
+9 SET SDSECN=0
FOR
SET SDSECN=$ORDER(VAEL(1,SDSECN))
if 'SDSECN
QUIT
WRITE !,"Secondary Eligibility Code: ",$PIECE(VAEL(1,SDSECN),U,2)
End DoDot:1
WRITE !!,"Current Eligibility for Encounter: ",$SELECT(SDCELIG'="":SDCELIG,1:"N/A")
QUIT
+10 SET (SDCNT,SDI)=0
+11 ;Reference to ^DPT(DFN,.372 supported by ICR #1476
+12 FOR
SET SDI=$ORDER(^DPT(DFN,.372,SDI))
if 'SDI
QUIT
IF $PIECE($GET(^(SDI,0)),"^",3)
SET SDRD0=^(0)
Begin DoDot:1
+13 SET SDCNT=SDCNT+1
+14 ;Reference to ^DIC(31,+SDRD0 supported by ICR #733
+15 SET SDDC=$PIECE($GET(^DIC(31,+SDRD0,0)),U)
+16 if SDCNT>1
WRITE !
+17 WRITE ?20,SDDC," (",$PIECE(SDRD0,"^",2),"%-",$SELECT($PIECE(SDRD0,"^",3):"SC",1:""),")"
End DoDot:1
+18 IF 'SDCNT
WRITE $SELECT('$ORDER(^DPT(DFN,.372,0)):"None Stated",1:"No Service Connected Disabilities Listed")
+19 WRITE !,"Primary Eligibility Code: ",$SELECT(+VAEL(1):$PIECE(VAEL(1),U,2),1:"N/A")
Begin DoDot:1
+20 SET SDSECN=0
FOR
SET SDSECN=$ORDER(VAEL(1,SDSECN))
if 'SDSECN
QUIT
WRITE !,"Secondary Eligibility Code: ",$PIECE(VAEL(1,SDSECN),U,2)
End DoDot:1
+21 WRITE !!,"Current Eligibility for Encounter: ",$SELECT(SDCELIG'="":SDCELIG,1:"N/A")
+22 QUIT
