DGRPDB ;ALB/AAS,JAN,ERC,PHH,HM,JAM - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ;24 Dec 2018 1:45 PM
;;5.3;Registration;**26,50,358,570,631,709,713,749,972,1064,1104**;Aug 13, 1993;Build 59
; Reference to $$ASC^PXCOMPACT in ICR #7327
;
% S:'$D(DGQUIT) DGQUIT=0
G:DGQUIT END S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC G:+Y<1 END S DFN=+Y D EN
G %
;
EN ;entry with DFN defined.
Q:'$D(DFN) D HOME^%ZIS,2^VADPT,HDR
;jam; DG*5.3*1064
I $$INDSTATUS^DGENELA2(DFN) W !,$$EZBLD^DIALOG(261133)
D MT,AOIR,ELIG,DIS,MOH ;added MOH DG*5.3*972
N DGINS
I $$INSUR^IBBAPI(DFN,"","AR",.DGINS,1)
S C="",C=$O(DGINS("IBBAPI","INSUR",C),-1),C=+C+6
D:($Y>(IOSL-C)) PAUSE,HDR:'DGQUIT Q:DGQUIT D INS,PAUSE
Q
;
ELIG ;eligibility code(s)
W !,"Acute Suicidal Crisis: ",$$ASC^PXCOMPACT(DFN)
W !," Primary Elig. Code: ",$P(VAEL(1),"^",2)," -- ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
I VAEL(8)]"" S Y=$S($D(^DPT(DFN,.361)):$P(^(.361),"^",2),1:"") W " " D DT^DIQ
W !,"Other Elig. Code(s): " I $D(VAEL(1))>9 S I1=0 F I=0:0 S I=$O(VAEL(1,I)) Q:'I S I1=I1+1 W:I1>1 !?21 W $P(VAEL(1,I),"^",2)
E W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
Q
;
;display medal of honor information DG*5.3*972 HM
MOH ;medal of honor
N DGMOHADT,DGMOHSDT,DGMOHCED
I $P($G(^DPT(DFN,.54)),"^")="Y" D
.W !," Medal of Honor: YES"
.N DGMOHADT,DGMOHEDT,DGMOHSDT
.S DGMOHADT=$P($G(^DPT(DFN,.54)),"^",2),DGMOHSDT=$P($G(^DPT(DFN,.54)),"^",3),DGMOHEDT=$P($G(^DPT(DFN,.54)),"^",4) ;get MOH AWARD DATE,MOH STATUS DATE, & MOH COPAYMENT EXEMPTION DATE
.I DGMOHADT="" S DGMOHADT="UNKNOWN",DGMOHEDT="Needs Determination" ;Display text when MOH AWARD DATE empty
.W ?35,"MOH Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE
.W !," MOH Award Date: "_$$FMTE^XLFDT(DGMOHADT,"5DZ") ;format MOH AWARD DATE
.W ?35,"MOH Copay Exemption Date: "_$$FMTE^XLFDT(DGMOHEDT,"5DZ") ;format MOH COPAYMENT EXEMPTION DATE
I $P($G(^DPT(DFN,.54)),"^")="N" D ;if MOH indicator is N
.N DGMOHSDT S DGMOHSDT=$P($G(^DPT(DFN,.54)),"^",3) ;set status date
.W !," Medal of Honor: NO"
.W ?35,"MOH Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE
.W !," MOH Award Date: "
.W ?35,"MOH Copay Exemption Date: "
I $P($G(^DPT(DFN,.54)),"^")="" D ;if MOH indicator is null
.W !," Medal of Honor: "
.W ?35,"MOH Status Date: "
.W !," MOH Award Date: "
.W ?35,"MOH Copay Exemption Date: "
Q
DIS ;rated disabilities - Integration Agreement #700
;
; This is called from the FEE and MCCR package!!!
;
; Input: DFN as IEN of PATIENT file
; VAEL array (if no passed, it is set) of eligibility info
;
I '$D(VAEL) D ELIG^VADPT S DGKVAR=1
W:'+VAEL(3) !!," Service Connected: NO" W:+VAEL(3) !!," SC Percent: ",$P(VAEL(3),"^",2)_"%"
N DGQUIT
W !," Rated Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" G DISQ
S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1) D
. S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",$P(I1,"^",3)']"":"not specified",1:"NSC")_")",1:""),I3=I3+1
. I $Y>(IOSL-3) D PAUSE I $G(DGQUIT)=0 W @IOF
. I $G(DGQUIT)=1 Q
. W:I3>1 !?21 W I2
W:'I3 "NONE STATED"
DISQ I $D(DGKVAR) D KVAR^VADPT K DGKVAR
K I,I1,I2,I3
Q
;
INS ;insurance information
;
; This is called form the FEE package!!!
;
; Input: DFN as IEN of PATIENT file
; DGINSDT as date to compute insurance flag as of (default DT)
;
Q:'$D(DFN)
W !!," Health Insurance: "
S Z=$$INSUR^IBBAPI(DFN,$S($D(DGINSDT):DGINSDT,1:DT))
W $S(Z:"YES",1:"NO")
D DISP^DGIBDSP
INSQ K I,I1,DGX,Z
Q
;
IN ; Old code
Q
;
AOIR ;Agent Orange/ionizing radiation/Camp Lejeune
N DGEC,NTA,DGCL
S DGX=$S($D(^DPT(DFN,.321)):^(.321),1:"")
F I=2,3 S X=$P(DGX,"^",I) W:I=2 !," A/O Exp.: " W:I=3 "ION Rad.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
S X=$G(^DPT(DFN,.38)),X1=$P(X,"^",1) W "Medicaid Elig: ",$S(X1="":"NOT ANSWERED",'X1:"NO",1:"YES") I ($X+15)'>IOM W " - " S Y=$P(X,"^",2) D D^DIQ W $P(Y,"@")
S DGEC=$S($D(^DPT(DFN,.322)):^DPT(DFN,.322),1:"")
S X=$P(DGEC,U,13) W !," Env Contam.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
S NTA=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
K DGNTARR
W "N/T Radium: " W $S(NTA'="":NTA,1:"NOT ANSWERED")
;DG*5.3*972 HM - Camp Lejeune will always be on next line
S DGCL=$S($D(^DPT(DFN,.3217)):^DPT(DFN,.3217),1:""),X=$P(DGCL,"^",1) W !," Camp Lejeune: " W $S(X="Y":"YES",X="N":"NO",1:"NOT ANSWERED")
Q
;
PAUSE F J=1:1 Q:($Y>(IOSL-3)) W !
S DGX1="" I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
Q
;
HDR ;Screen Header
W @IOF I $P(VAEL(6),"^",2)]"" S DGTYPE=$P(VAEL(6),"^",2)
W $P(VADM(1),"^",1),?32,VA("PID"),?47,$P(VADM(3),"^",2) S X=$S($D(DGTYPE):$P(DGTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
S X="",$P(X,"=",80)="" W !,X Q
Q
;
MT I '$O(^DGMT(408.31,"AD",1,DFN,0)) W !," Means Test Status: NOT IN MEANS TEST FILE" Q
;if patient is on a DOM ward, don't display Means Test required message
D DOM^DGMTR D:'$G(DGDOM) DIS^DGMTU(DFN) K DGDOM
Q
;
END D KVAR^VADPT
K A,C,I,I1,I2,I3,J,DIC,DIR,DFN,DGA1,DGMT,DGMTL,DGMTLA,DGX,DGX1,DGT,DGTYPE,DGQUIT,DGMTLL,X,X1,VAROOT,VA,Y,Z
Q
;
RDIS(DGDFN,DGARR) ;API to return all Rated Disabilities from the
;Patient file for a patient using an array. Returned in descending Service Connected percent.
;
; Integration Agreement #4807
;
;Input DGDFN - IEN of patient file (required)
;Input/Output DGARR - name of array for returned disability info (required)
; piece 1 - Disability IEN (in file 31)
; piece 2 - Disability %
; piece 3 - SC? (1,0)
; piece 4 - extremity affected
; piece 5 - original effective date
; piece 6 - current effective date
;Output 1=successful and array returned with data
; 0=unsuccessful and no array
;
N DGARR1,DGC,DGCC,DGERR,DGNODE,DGCT,DGE,DGEE
K DGW,DGARR
I $G(DGDFN)']"" Q 0
I '$D(^DPT(DGDFN,0)) Q 0
D GETS^DIQ(2,DGDFN,".3721*","I","DGARR1","DGERR")
I $D(DGERR) Q 0
S DGCC=0
S DGCC=$O(^DPT(DGDFN,.372,DGCC))
I 'DGCC Q 0
S DGC=""
F S DGC=$O(DGARR1(2.04,DGC)) Q:DGC']"" D
. S DGNODE=DGC
. S DGARR(DGC)=DGARR1(2.04,DGNODE,.01,"I")_"^"_DGARR1(2.04,DGNODE,2,"I")_"^"_DGARR1(2.04,DGNODE,3,"I")_"^"_DGARR1(2.04,DGNODE,4,"I")_"^"_DGARR1(2.04,DGNODE,5,"I")_"^"_DGARR1(2.04,DGNODE,6,"I")
S DGE=""
F S DGE=$O(DGARR(DGE)) Q:'DGE D
. I $P(DGARR(DGE),U,2)="" S $P(DGARR(DGE),U,2)=0
. S DGW($P(DGARR(DGE),U,2),$P(DGE,",",1))=DGARR(DGE)
S DGE="",DGCT=1
K DGARR
F S DGE=$O(DGW(DGE),-1) Q:DGE']"" D
. F DGEE=0:0 S DGEE=$O(DGW(DGE,DGEE)) Q:DGEE'>0 D
. . S DGARR(DGCT)=DGW(DGE,DGEE) S DGCT=DGCT+1
K DGW
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPDB 6987 printed Sep 23, 2025@20:32:04 Page 2
DGRPDB ;ALB/AAS,JAN,ERC,PHH,HM,JAM - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ;24 Dec 2018 1:45 PM
+1 ;;5.3;Registration;**26,50,358,570,631,709,713,749,972,1064,1104**;Aug 13, 1993;Build 59
+2 ; Reference to $$ASC^PXCOMPACT in ICR #7327
+3 ;
% if '$DATA(DGQUIT)
SET DGQUIT=0
+1 if DGQUIT
GOTO END
SET DIC="^DPT("
SET DIC(0)="AEQMN"
DO ^DIC
if +Y<1
GOTO END
SET DFN=+Y
DO EN
+2 GOTO %
+3 ;
EN ;entry with DFN defined.
+1 if '$DATA(DFN)
QUIT
DO HOME^%ZIS
DO 2^VADPT
DO HDR
+2 ;jam; DG*5.3*1064
+3 IF $$INDSTATUS^DGENELA2(DFN)
WRITE !,$$EZBLD^DIALOG(261133)
+4 ;added MOH DG*5.3*972
DO MT
DO AOIR
DO ELIG
DO DIS
DO MOH
+5 NEW DGINS
+6 IF $$INSUR^IBBAPI(DFN,"","AR",.DGINS,1)
+7 SET C=""
SET C=$ORDER(DGINS("IBBAPI","INSUR",C),-1)
SET C=+C+6
+8 if ($Y>(IOSL-C))
DO PAUSE
if 'DGQUIT
DO HDR
if DGQUIT
QUIT
DO INS
DO PAUSE
+9 QUIT
+10 ;
ELIG ;eligibility code(s)
+1 WRITE !,"Acute Suicidal Crisis: ",$$ASC^PXCOMPACT(DFN)
+2 WRITE !," Primary Elig. Code: ",$PIECE(VAEL(1),"^",2)," -- ",$SELECT(VAEL(8)']"":"NOT VERIFIED",1:$PIECE(VAEL(8),"^",2))
+3 IF VAEL(8)]""
SET Y=$SELECT($DATA(^DPT(DFN,.361)):$PIECE(^(.361),"^",2),1:"")
WRITE " "
DO DT^DIQ
+4 WRITE !,"Other Elig. Code(s): "
IF $DATA(VAEL(1))>9
SET I1=0
FOR I=0:0
SET I=$ORDER(VAEL(1,I))
if 'I
QUIT
SET I1=I1+1
if I1>1
WRITE !?21
WRITE $PIECE(VAEL(1,I),"^",2)
+5 IF '$TEST
WRITE "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
+6 QUIT
+7 ;
+8 ;display medal of honor information DG*5.3*972 HM
MOH ;medal of honor
+1 NEW DGMOHADT,DGMOHSDT,DGMOHCED
+2 IF $PIECE($GET(^DPT(DFN,.54)),"^")="Y"
Begin DoDot:1
+3 WRITE !," Medal of Honor: YES"
+4 NEW DGMOHADT,DGMOHEDT,DGMOHSDT
+5 ;get MOH AWARD DATE,MOH STATUS DATE, & MOH COPAYMENT EXEMPTION DATE
SET DGMOHADT=$PIECE($GET(^DPT(DFN,.54)),"^",2)
SET DGMOHSDT=$PIECE($GET(^DPT(DFN,.54)),"^",3)
SET DGMOHEDT=$PIECE($GET(^DPT(DFN,.54)),"^",4)
+6 ;Display text when MOH AWARD DATE empty
IF DGMOHADT=""
SET DGMOHADT="UNKNOWN"
SET DGMOHEDT="Needs Determination"
+7 ;format MOH STATUS DATE
WRITE ?35,"MOH Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ")
+8 ;format MOH AWARD DATE
WRITE !," MOH Award Date: "_$$FMTE^XLFDT(DGMOHADT,"5DZ")
+9 ;format MOH COPAYMENT EXEMPTION DATE
WRITE ?35,"MOH Copay Exemption Date: "_$$FMTE^XLFDT(DGMOHEDT,"5DZ")
End DoDot:1
+10 ;if MOH indicator is N
IF $PIECE($GET(^DPT(DFN,.54)),"^")="N"
Begin DoDot:1
+11 ;set status date
NEW DGMOHSDT
SET DGMOHSDT=$PIECE($GET(^DPT(DFN,.54)),"^",3)
+12 WRITE !," Medal of Honor: NO"
+13 ;format MOH STATUS DATE
WRITE ?35,"MOH Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ")
+14 WRITE !," MOH Award Date: "
+15 WRITE ?35,"MOH Copay Exemption Date: "
End DoDot:1
+16 ;if MOH indicator is null
IF $PIECE($GET(^DPT(DFN,.54)),"^")=""
Begin DoDot:1
+17 WRITE !," Medal of Honor: "
+18 WRITE ?35,"MOH Status Date: "
+19 WRITE !," MOH Award Date: "
+20 WRITE ?35,"MOH Copay Exemption Date: "
End DoDot:1
+21 QUIT
DIS ;rated disabilities - Integration Agreement #700
+1 ;
+2 ; This is called from the FEE and MCCR package!!!
+3 ;
+4 ; Input: DFN as IEN of PATIENT file
+5 ; VAEL array (if no passed, it is set) of eligibility info
+6 ;
+7 IF '$DATA(VAEL)
DO ELIG^VADPT
SET DGKVAR=1
+8 if '+VAEL(3)
WRITE !!," Service Connected: NO"
if +VAEL(3)
WRITE !!," SC Percent: ",$PIECE(VAEL(3),"^",2)_"%"
+9 NEW DGQUIT
+10 WRITE !," Rated Disabilities: "
IF 'VAEL(4)
IF $SELECT('$DATA(^DG(391,+VAEL(6),0)):1,$PIECE(^(0),"^",2):0,1:1)
WRITE "NOT A VETERAN"
GOTO DISQ
+11 SET I3=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I!($GET(DGQUIT)=1)
QUIT
Begin DoDot:1
+12 SET I1=^(I,0)
SET I2=$SELECT($DATA(^DIC(31,+I1,0)):$PIECE(^(0),"^",1)_" ("_+$PIECE(I1,"^",2)_"%-"_$SELECT($PIECE(I1,"^",3):"SC",$PIECE(I1,"^",3)']"":"not specified",1:"NSC")_")",1:"")
SET I3=I3+1
+13 IF $Y>(IOSL-3)
DO PAUSE
IF $GET(DGQUIT)=0
WRITE @IOF
+14 IF $GET(DGQUIT)=1
QUIT
+15 if I3>1
WRITE !?21
WRITE I2
End DoDot:1
+16 if 'I3
WRITE "NONE STATED"
DISQ IF $DATA(DGKVAR)
DO KVAR^VADPT
KILL DGKVAR
+1 KILL I,I1,I2,I3
+2 QUIT
+3 ;
INS ;insurance information
+1 ;
+2 ; This is called form the FEE package!!!
+3 ;
+4 ; Input: DFN as IEN of PATIENT file
+5 ; DGINSDT as date to compute insurance flag as of (default DT)
+6 ;
+7 if '$DATA(DFN)
QUIT
+8 WRITE !!," Health Insurance: "
+9 SET Z=$$INSUR^IBBAPI(DFN,$SELECT($DATA(DGINSDT):DGINSDT,1:DT))
+10 WRITE $SELECT(Z:"YES",1:"NO")
+11 DO DISP^DGIBDSP
INSQ KILL I,I1,DGX,Z
+1 QUIT
+2 ;
IN ; Old code
+1 QUIT
+2 ;
AOIR ;Agent Orange/ionizing radiation/Camp Lejeune
+1 NEW DGEC,NTA,DGCL
+2 SET DGX=$SELECT($DATA(^DPT(DFN,.321)):^(.321),1:"")
+3 FOR I=2,3
SET X=$PIECE(DGX,"^",I)
if I=2
WRITE !," A/O Exp.: "
if I=3
WRITE "ION Rad.: "
WRITE $SELECT(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
+4 SET X=$GET(^DPT(DFN,.38))
SET X1=$PIECE(X,"^",1)
WRITE "Medicaid Elig: ",$SELECT(X1="":"NOT ANSWERED",'X1:"NO",1:"YES")
IF ($X+15)'>IOM
WRITE " - "
SET Y=$PIECE(X,"^",2)
DO D^DIQ
WRITE $PIECE(Y,"@")
+5 SET DGEC=$SELECT($DATA(^DPT(DFN,.322)):^DPT(DFN,.322),1:"")
+6 SET X=$PIECE(DGEC,U,13)
WRITE !," Env Contam.: "
WRITE $SELECT(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
+7 SET NTA=$SELECT($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
+8 KILL DGNTARR
+9 WRITE "N/T Radium: "
WRITE $SELECT(NTA'="":NTA,1:"NOT ANSWERED")
+10 ;DG*5.3*972 HM - Camp Lejeune will always be on next line
+11 SET DGCL=$SELECT($DATA(^DPT(DFN,.3217)):^DPT(DFN,.3217),1:"")
SET X=$PIECE(DGCL,"^",1)
WRITE !," Camp Lejeune: "
WRITE $SELECT(X="Y":"YES",X="N":"NO",1:"NOT ANSWERED")
+12 QUIT
+13 ;
PAUSE FOR J=1:1
if ($Y>(IOSL-3))
QUIT
WRITE !
+1 SET DGX1=""
IF $EXTRACT(IOST,1,2)["C-"
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET DGQUIT='Y
+2 QUIT
+3 ;
HDR ;Screen Header
+1 WRITE @IOF
IF $PIECE(VAEL(6),"^",2)]""
SET DGTYPE=$PIECE(VAEL(6),"^",2)
+2 WRITE $PIECE(VADM(1),"^",1),?32,VA("PID"),?47,$PIECE(VADM(3),"^",2)
SET X=$SELECT($DATA(DGTYPE):$PIECE(DGTYPE,"^",1),1:"PATIENT TYPE UNKNOWN")
SET X1=79-$LENGTH(X)
WRITE ?X1,X
+3 SET X=""
SET $PIECE(X,"=",80)=""
WRITE !,X
QUIT
+4 QUIT
+5 ;
MT IF '$ORDER(^DGMT(408.31,"AD",1,DFN,0))
WRITE !," Means Test Status: NOT IN MEANS TEST FILE"
QUIT
+1 ;if patient is on a DOM ward, don't display Means Test required message
+2 DO DOM^DGMTR
if '$GET(DGDOM)
DO DIS^DGMTU(DFN)
KILL DGDOM
+3 QUIT
+4 ;
END DO KVAR^VADPT
+1 KILL A,C,I,I1,I2,I3,J,DIC,DIR,DFN,DGA1,DGMT,DGMTL,DGMTLA,DGX,DGX1,DGT,DGTYPE,DGQUIT,DGMTLL,X,X1,VAROOT,VA,Y,Z
+2 QUIT
+3 ;
RDIS(DGDFN,DGARR) ;API to return all Rated Disabilities from the
+1 ;Patient file for a patient using an array. Returned in descending Service Connected percent.
+2 ;
+3 ; Integration Agreement #4807
+4 ;
+5 ;Input DGDFN - IEN of patient file (required)
+6 ;Input/Output DGARR - name of array for returned disability info (required)
+7 ; piece 1 - Disability IEN (in file 31)
+8 ; piece 2 - Disability %
+9 ; piece 3 - SC? (1,0)
+10 ; piece 4 - extremity affected
+11 ; piece 5 - original effective date
+12 ; piece 6 - current effective date
+13 ;Output 1=successful and array returned with data
+14 ; 0=unsuccessful and no array
+15 ;
+16 NEW DGARR1,DGC,DGCC,DGERR,DGNODE,DGCT,DGE,DGEE
+17 KILL DGW,DGARR
+18 IF $GET(DGDFN)']""
QUIT 0
+19 IF '$DATA(^DPT(DGDFN,0))
QUIT 0
+20 DO GETS^DIQ(2,DGDFN,".3721*","I","DGARR1","DGERR")
+21 IF $DATA(DGERR)
QUIT 0
+22 SET DGCC=0
+23 SET DGCC=$ORDER(^DPT(DGDFN,.372,DGCC))
+24 IF 'DGCC
QUIT 0
+25 SET DGC=""
+26 FOR
SET DGC=$ORDER(DGARR1(2.04,DGC))
if DGC']""
QUIT
Begin DoDot:1
+27 SET DGNODE=DGC
+28 SET DGARR(DGC)=DGARR1(2.04,DGNODE,.01,"I")_"^"_DGARR1(2.04,DGNODE,2,"I")_"^"_DGARR1(2.04,DGNODE,3,"I")_"^"_DGARR1(2.04,DGNODE,4,"I")_"^"_DGARR1(2.04,DGNODE,5,"I")_"^"_DGARR1(2.04,DGNODE,6,"I")
End DoDot:1
+29 SET DGE=""
+30 FOR
SET DGE=$ORDER(DGARR(DGE))
if 'DGE
QUIT
Begin DoDot:1
+31 IF $PIECE(DGARR(DGE),U,2)=""
SET $PIECE(DGARR(DGE),U,2)=0
+32 SET DGW($PIECE(DGARR(DGE),U,2),$PIECE(DGE,",",1))=DGARR(DGE)
End DoDot:1
+33 SET DGE=""
SET DGCT=1
+34 KILL DGARR
+35 FOR
SET DGE=$ORDER(DGW(DGE),-1)
if DGE']""
QUIT
Begin DoDot:1
+36 FOR DGEE=0:0
SET DGEE=$ORDER(DGW(DGE,DGEE))
if DGEE'>0
QUIT
Begin DoDot:2
+37 SET DGARR(DGCT)=DGW(DGE,DGEE)
SET DGCT=DGCT+1
End DoDot:2
End DoDot:1
+38 KILL DGW
+39 QUIT 1
+40 ;
