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