- DGBTE1 ;ALB/SCK/GAH,LAB - BENEFICIARY TRAVEL FIND OLD CLAIM DATES ; 03/20/2019
- ;;1.0;Beneficiary Travel;**8,12,13,20,21,22,25,28,33,34,37,39**;September 25, 2001;Build 6
- DATE ; get date for claim, either new or past date
- N DGBTDCLM
- K ^TMP("DGBT",$J),^TMP("DGBTARA",$J),DIR
- I 'DGBTNEW S DIR("A",2)="Enter a 'P' to display Past CLAIM dates for editing."
- S DIR("A",3)="Time is required when adding a new CLAIM.",DIR("A",4)="",DIR("A",1)="",DIR("A")="Select TRAVEL CLAIM DATE/TIME",DIR("?")="^D HELP^DGBTE1A"
- S DIR(0)="F",DIR("B")="NOW" D ^DIR K DIR G ERR1:$D(DIRUT)
- S CHZFLG=0,%DT="EXR",DTSUB=$S(Y="N":"NOW",Y="P":"OLD",Y="p":"OLD",1:"OTHR")_"^DGBTE1A" D @DTSUB ;PAVEL - DGBT*1*20
- S:$P(DTSUB,U,1)="OLD"&(Y1>0) DGBTOLD=1 K DTSUB ;PAVEL DGBT*1*20
- G ERR1:$D(DTOUT),DATE:Y1<0 S DGBTA=Y1 G SET:CHZFLG ;PAVEL DGBT*1*20
- DATE1 ; for past claims, set DGBTDT to inverse date of claim date
- I $D(^DGBT(392,"C",DFN)) D
- . S DGBTC=0,DGBTDT=9999999-$E(DGBTA,1,7) ; set past claims counter=0
- . ; for latest date (topmost) search for past claims
- . F I=DGBTDT:0 S I=$O(^DGBT(392,"AI",DFN,I)) Q:'I!(I>(DGBTDT_.99999)) S DGBTC=DGBTC+1,DGBT(DGBTC)=9999999.99999-I
- I '$D(DGBT) G LOCK
- W !!,"There are other claims on this date.",!,"Select by number to edit or <RETURN> to add a new CLAIM.",!
- ; convert inverse claim date to external format through VADATE conversion routine
- F I=0:0 S I=$O(DGBT(I)) Q:'I D
- .S DGBTDCLM=$$GET1^DIQ(392,DGBT(I),45,"I")
- .S VADAT("W")=DGBT(I) D ^VADATE W !?5,I,".",?10,VADATE("E")_$S($G(DGBTDCLM)'="":" (D)",1:"")
- K DIR S DIR("A")="Select 1"_$S(DGBTC=1:"",1:"-"_DGBTC)_", or <RETURN> to add a new claim: ",DIR(0)="NOA^1:"_DGBTC,DIR("?")="Select, by number, one of the displayed claim dates: "
- D ^DIR K DIR S:$G(Y) CHZFLG=1 G QUIT^DGBTEND:$D(DTOUT)!($D(DUOUT))
- G LOCK:Y="" G DATE:'$D(DGBT(Y))
- S DGBTA=DGBT(Y),DGBTOLD=1 G SET
- LOCK ;
- ;L +^DGBT(392,DGBTA):$G(DILOCKTM,3)
- ;I '$T!$D(^DGBT(392,DGBTA)) L -^DGBT(392,DGBTA) S DGBTA=$$FMADD^XLFDT(DGBTA,,,,1) G LOCK ;dbe patch DGBT*1*21
- ;dgbt*1.0*33 - more efficient lookup
- F Q:'$D(^DGBT(392,DGBTA)) S DGBTA=$$FMADD^XLFDT(DGBTA,,,,1)
- L +^DGBT(392,DGBTA):$G(DILOCKTM,3) E S DGBTA=$$FMADD^XLFDT(DGBTA,,,,1) G LOCK ;dgbt*1.0*34 - added to increment if lock exists for record # that has not been created yet
- S (DGBTDT,VADAT("W"))=DGBTA D ^VADATE W VADATE("E") ;for CCR235 by RE
- ASKADD ;
- W !!,"Are you sure you want to add a new claim"
- S %=1 D YN^DICN I (%<0)!(%=2) L -^DGBT(392,DGBTA) G EXIT2^DGBTE ;dgbt*1.0*34 - unlock record immediately if user chooses no or exits
- I '% W !!,"Enter 'YES' to add a new claim, or 'NO' not to add the claim." G ASKADD
- K DD,DO
- ; create new file entry, stuff patient DFN into name field(pointer)
- ;DGBT*1.0*37 replace 4 slashes with ///, 2///' - ' allows for internal value to be validated and pushed in.
- S (X,DINUM)=DGBTA,DIC="^DGBT(392,",DIC(0)="L",DIC("DR")="2///`"_DFN
- D FILE^DICN K DIC L -^DGBT(392,DGBTA)
- ; go back to patient if no file entry
- G:Y'>0 PATIENT^DGBTE
- SET ; call inhouse generic date routine
- S (DA,DGBTDT,VADAT("W"))=DGBTA D ^VADATE
- ; get internal and external formats of converted inverse dates
- S DGBTDTI=$S($G(VADAT("W"))'="":VADAT("W"),1:VADATE("I")),DGBTDTE=VADATE("E") K VADAT,VADATE,DIC,Y
- I $G(DGBTDIVI)'="" S DGBTDIVN=$P(^DG(40.8,DGBTDIVI,0),"^",7)
- D GA^DGBTUTL(DFN,"DGBTINCA",DGBTDTI) ;Get Alternate Income PAVEL
- STUFF ; stuff departure with address data from patient file, dest from institution file
- S DGBTCMTY=$$GET1^DIQ(392,DGBTDT,56)
- S:'$L(DGBTCMTY) DGBTCMTY="M"
- D RESADDR^DGBTUTL1(.DGBTADDR) ;*39 - get values for address
- ;dbe patch DGBT*1*25 - removed restrictions below to allow departure and destination fields to get filed for existing claims
- S:'$D(^DGBT(392,DGBTDT,"D")) ^DGBT(392,DGBTDT,"D")=DGBTADDR(1)_"^"_DGBTADDR(2)_"^"_DGBTADDR(3)_"^"_DGBTADDR(4)_"^"_$S(DGBTADDR(5)]"":+DGBTADDR(5),1:"")_"^"_$P(DGBTADDR(6),U) ;*39 - updated to use residential address
- I '$D(^DGBT(392,DGBTDT,"T")) D
- . S X=$S($D(^DIC(4,DGBTDIVN,1)):^(1),1:"")
- . S ^DGBT(392,DGBTDT,"T")=($P(^DG(40.8,DGBTDIVI,0),U)_"^"_$P(X,U)_"^"_$P(X,U,2)_"^"_$P(X,U,3)_"^"_$P(^DIC(4,DGBTDIVN,0),U,2)_"^"_$TR($P(X,U,4),"-","")) ;*28 remove hyphen from zip code
- Q:$G(DGBTSP2M) ;dbe patch DGBT*1*25 - added quit when called from routine dgbtee
- CHKFILES ; section removed, dependents picked up below in MEANS ; abr 10/94
- MEANS ; find corres. means test entry, gets MT income, status, no. of dependents
- ;DGBTMTS= MT Status; DGBTCSC= claim Service Connected indicator & %; DGBTELG=Eligibility status
- N X,X2,X3,Y,DGBTIFL
- S X=$$LST^DGMTCOU1(DFN,DT,3),DGBTMTS=$P(X,U,4)_U_$P(X,U,3) ; returns corres. MT info,X=IEN of last MT. passing a 3 will check both MT and RX Co-Pays
- ; get income, # dependents
- S Y=$$INCOME^VAFMON(DFN,DGBTA,1)
- S:"I^V"[$P(Y,U,2) Y=U ;If income type is I or V ignore it PAVEL
- S:DGBTINCA Y=$P(DGBTINCA,U,2)_U_$E($P(DGBTINCA,U,4)) ;Set Alternate Income
- S X=$P(Y,U),DGBTIFL=$P(Y,U,2) ; returns income & source.
- I X?1N.E!(X<0) D
- .I X<0 S X=0
- .S X2="0$",X3=8 D COMMA^%DTC
- S DGBTINC=X_U_$G(DGBTIFL) K X,X2
- S DGBTDEP=$$DEP^VAFMON(DFN,DGBTA) ; finds dependents Vet, Spouse, Children
- S DGBTDTY=" (Year: "_$$FMTE^XLFDT($E(DGBTDTI,1,3)_"0000")_")" ;Year to be displayed with Income
- S DGBTMTTH=$$MTTH^DGBTMTTH(DGBTDEP,DGBTDTI) ; Means test threshold
- S DGBTRXTH=+$$THRES^IBARXEU1(DGBTDTI,1,DGBTDEP) ; RX co-pay threshold
- S DGBTDYFL=$$DAYFLAG^DGBTUTL ; valid income test y/n
- ;
- PREV ; if past claim get SC%, elig.
- I CHZFLG S X=^DGBT(392,DGBTA,0),DGBTELG=$P(X,U,3),DGBTCSC=$P(X,U,4) D
- . S:$P(X,U,11) DGBTDIVI=+$P(X,U,11),DGBTDIVN=$P($G(^DG(40.8,DGBTDIVI,0)),U,7) ;dbe patch DGBT*1*22 - save division of existing claims
- . S:DGBTCSC DGBTCSC=1_U_DGBTCSC S:'DGBTCSC DGBTCSC=0
- . S:DGBTELG DGBTELG=DGBTELG_U_$P(^DIC(8,DGBTELG,0),U)
- CERT ; get last BT certification, get date, then get eligibility
- I $D(^DGBT(392.2,"C",DFN)) D
- .;cd=cert date in inverse then external format, ce= eligibility, ca* = amt certified
- . S DGBTCD=$O(^DGBT(392.2,"C",DFN,0)),DGBTCE=$P(^DGBT(392.2,DGBTCD,0),"^",3)
- . S DGBTCA=$P(^DGBT(392.2,DGBTCD,0),"^",4),Y=9999999-$P(DGBTCD,".")
- . X ^DD("DD") ; date conversion, y=cert date (internal)
- . S DGBTCD=Y,X=DGBTCA,X2="0$",X3=8 K Y D COMMA^%DTC S DGBTCA=X K X,X2,X3
- APPTS ; search patient file for appointments through claim date (DTI+1), add dates to array DGBTCL
- N ERRCODE,DGARRAY,CLIEN,APTDT S DGARRAY("FLDS")="2;3;10;18"
- S DGARRAY(4)=DFN,I=$$SDAPI^SDAMA301(.DGARRAY)
- ; I<0 = Error, I<0 = # of Records retrieved
- I I<0 S ERRCODE=$O(^TMP($J,"SDAMA301","")),I1=1,DGBTCL("ERROR")=^TMP($J,"SDAMA301",ERRCODE)
- I I>0 D
- .S CLIEN=""
- .F S CLIEN=$O(^TMP($J,"SDAMA301",DFN,CLIEN)) Q:'CLIEN D
- ..S APTDT=DGBTDTI\1
- ..F S APTDT=$O(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT)) Q:'APTDT!(APTDT>(DGBTDTI+1)) D
- ...S SDATA=^TMP($J,"SDAMA301",DFN,CLIEN,APTDT)
- ...S DGBTCL(APTDT)=$P($P(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),U,2),";",2)_U_$P($P(SDATA,U,3),";")
- ...S DGBTCL(APTDT)=DGBTCL(APTDT)_U_$P($P(SDATA,U,18),";")_U_$P($P(SDATA,U,10),";")
- K ^TMP($J,"SDAMA301"),DGARRAY,CLIEN,APTDT
- EXIT ; exit routine
- Q
- ERR1 ; error condition
- G QUIT^DGBTEND Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTE1 7229 printed Feb 18, 2025@23:07:02 Page 2
- DGBTE1 ;ALB/SCK/GAH,LAB - BENEFICIARY TRAVEL FIND OLD CLAIM DATES ; 03/20/2019
- +1 ;;1.0;Beneficiary Travel;**8,12,13,20,21,22,25,28,33,34,37,39**;September 25, 2001;Build 6
- DATE ; get date for claim, either new or past date
- +1 NEW DGBTDCLM
- +2 KILL ^TMP("DGBT",$JOB),^TMP("DGBTARA",$JOB),DIR
- +3 IF 'DGBTNEW
- SET DIR("A",2)="Enter a 'P' to display Past CLAIM dates for editing."
- +4 SET DIR("A",3)="Time is required when adding a new CLAIM."
- SET DIR("A",4)=""
- SET DIR("A",1)=""
- SET DIR("A")="Select TRAVEL CLAIM DATE/TIME"
- SET DIR("?")="^D HELP^DGBTE1A"
- +5 SET DIR(0)="F"
- SET DIR("B")="NOW"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO ERR1
- +6 ;PAVEL - DGBT*1*20
- SET CHZFLG=0
- SET %DT="EXR"
- SET DTSUB=$SELECT(Y="N":"NOW",Y="P":"OLD",Y="p":"OLD",1:"OTHR")_"^DGBTE1A"
- DO @DTSUB
- +7 ;PAVEL DGBT*1*20
- if $PIECE(DTSUB,U,1)="OLD"&(Y1>0)
- SET DGBTOLD=1
- KILL DTSUB
- +8 ;PAVEL DGBT*1*20
- if $DATA(DTOUT)
- GOTO ERR1
- if Y1<0
- GOTO DATE
- SET DGBTA=Y1
- if CHZFLG
- GOTO SET
- DATE1 ; for past claims, set DGBTDT to inverse date of claim date
- +1 IF $DATA(^DGBT(392,"C",DFN))
- Begin DoDot:1
- +2 ; set past claims counter=0
- SET DGBTC=0
- SET DGBTDT=9999999-$EXTRACT(DGBTA,1,7)
- +3 ; for latest date (topmost) search for past claims
- +4 FOR I=DGBTDT:0
- SET I=$ORDER(^DGBT(392,"AI",DFN,I))
- if 'I!(I>(DGBTDT_.99999))
- QUIT
- SET DGBTC=DGBTC+1
- SET DGBT(DGBTC)=9999999.99999-I
- End DoDot:1
- +5 IF '$DATA(DGBT)
- GOTO LOCK
- +6 WRITE !!,"There are other claims on this date.",!,"Select by number to edit or <RETURN> to add a new CLAIM.",!
- +7 ; convert inverse claim date to external format through VADATE conversion routine
- +8 FOR I=0:0
- SET I=$ORDER(DGBT(I))
- if 'I
- QUIT
- Begin DoDot:1
- +9 SET DGBTDCLM=$$GET1^DIQ(392,DGBT(I),45,"I")
- +10 SET VADAT("W")=DGBT(I)
- DO ^VADATE
- WRITE !?5,I,".",?10,VADATE("E")_$SELECT($GET(DGBTDCLM)'="":" (D)",1:"")
- End DoDot:1
- +11 KILL DIR
- SET DIR("A")="Select 1"_$SELECT(DGBTC=1:"",1:"-"_DGBTC)_", or <RETURN> to add a new claim: "
- SET DIR(0)="NOA^1:"_DGBTC
- SET DIR("?")="Select, by number, one of the displayed claim dates: "
- +12 DO ^DIR
- KILL DIR
- if $GET(Y)
- SET CHZFLG=1
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO QUIT^DGBTEND
- +13 if Y=""
- GOTO LOCK
- if '$DATA(DGBT(Y))
- GOTO DATE
- +14 SET DGBTA=DGBT(Y)
- SET DGBTOLD=1
- GOTO SET
- LOCK ;
- +1 ;L +^DGBT(392,DGBTA):$G(DILOCKTM,3)
- +2 ;I '$T!$D(^DGBT(392,DGBTA)) L -^DGBT(392,DGBTA) S DGBTA=$$FMADD^XLFDT(DGBTA,,,,1) G LOCK ;dbe patch DGBT*1*21
- +3 ;dgbt*1.0*33 - more efficient lookup
- +4 FOR
- if '$DATA(^DGBT(392,DGBTA))
- QUIT
- SET DGBTA=$$FMADD^XLFDT(DGBTA,,,,1)
- +5 ;dgbt*1.0*34 - added to increment if lock exists for record # that has not been created yet
- LOCK +^DGBT(392,DGBTA):$GET(DILOCKTM,3)
- IF '$TEST
- SET DGBTA=$$FMADD^XLFDT(DGBTA,,,,1)
- GOTO LOCK
- +6 ;for CCR235 by RE
- SET (DGBTDT,VADAT("W"))=DGBTA
- DO ^VADATE
- WRITE VADATE("E")
- ASKADD ;
- +1 WRITE !!,"Are you sure you want to add a new claim"
- +2 ;dgbt*1.0*34 - unlock record immediately if user chooses no or exits
- SET %=1
- DO YN^DICN
- IF (%<0)!(%=2)
- LOCK -^DGBT(392,DGBTA)
- GOTO EXIT2^DGBTE
- +3 IF '%
- WRITE !!,"Enter 'YES' to add a new claim, or 'NO' not to add the claim."
- GOTO ASKADD
- +4 KILL DD,DO
- +5 ; create new file entry, stuff patient DFN into name field(pointer)
- +6 ;DGBT*1.0*37 replace 4 slashes with ///, 2///' - ' allows for internal value to be validated and pushed in.
- +7 SET (X,DINUM)=DGBTA
- SET DIC="^DGBT(392,"
- SET DIC(0)="L"
- SET DIC("DR")="2///`"_DFN
- +8 DO FILE^DICN
- KILL DIC
- LOCK -^DGBT(392,DGBTA)
- +9 ; go back to patient if no file entry
- +10 if Y'>0
- GOTO PATIENT^DGBTE
- SET ; call inhouse generic date routine
- +1 SET (DA,DGBTDT,VADAT("W"))=DGBTA
- DO ^VADATE
- +2 ; get internal and external formats of converted inverse dates
- +3 SET DGBTDTI=$SELECT($GET(VADAT("W"))'="":VADAT("W"),1:VADATE("I"))
- SET DGBTDTE=VADATE("E")
- KILL VADAT,VADATE,DIC,Y
- +4 IF $GET(DGBTDIVI)'=""
- SET DGBTDIVN=$PIECE(^DG(40.8,DGBTDIVI,0),"^",7)
- +5 ;Get Alternate Income PAVEL
- DO GA^DGBTUTL(DFN,"DGBTINCA",DGBTDTI)
- STUFF ; stuff departure with address data from patient file, dest from institution file
- +1 SET DGBTCMTY=$$GET1^DIQ(392,DGBTDT,56)
- +2 if '$LENGTH(DGBTCMTY)
- SET DGBTCMTY="M"
- +3 ;*39 - get values for address
- DO RESADDR^DGBTUTL1(.DGBTADDR)
- +4 ;dbe patch DGBT*1*25 - removed restrictions below to allow departure and destination fields to get filed for existing claims
- +5 ;*39 - updated to use residential address
- if '$DATA(^DGBT(392,DGBTDT,"D"))
- SET ^DGBT(392,DGBTDT,"D")=DGBTADDR(1)_"^"_DGBTADDR(2)_"^"_DGBTADDR(3)_"^"_DGBTADDR(4)_"^"_$SELECT(DGBTADDR(5)]"":+DGBTADDR(5),1:"")_"^"_$PIECE(DGBTADDR(6),U)
- +6 IF '$DATA(^DGBT(392,DGBTDT,"T"))
- Begin DoDot:1
- +7 SET X=$SELECT($DATA(^DIC(4,DGBTDIVN,1)):^(1),1:"")
- +8 ;*28 remove hyphen from zip code
- SET ^DGBT(392,DGBTDT,"T")=($PIECE(^DG(40.8,DGBTDIVI,0),U)_"^"_$PIECE(X,U)_"^"_$PIECE(X,U,2)_"^"_$PIECE(X,U,3)_"^"_$PIECE(^DIC(4,DGBTDIVN,0),U,2)_"^"_$TRANSLATE($PIECE(X,U,4),"-",""))
- End DoDot:1
- +9 ;dbe patch DGBT*1*25 - added quit when called from routine dgbtee
- if $GET(DGBTSP2M)
- QUIT
- CHKFILES ; section removed, dependents picked up below in MEANS ; abr 10/94
- MEANS ; find corres. means test entry, gets MT income, status, no. of dependents
- +1 ;DGBTMTS= MT Status; DGBTCSC= claim Service Connected indicator & %; DGBTELG=Eligibility status
- +2 NEW X,X2,X3,Y,DGBTIFL
- +3 ; returns corres. MT info,X=IEN of last MT. passing a 3 will check both MT and RX Co-Pays
- SET X=$$LST^DGMTCOU1(DFN,DT,3)
- SET DGBTMTS=$PIECE(X,U,4)_U_$PIECE(X,U,3)
- +4 ; get income, # dependents
- +5 SET Y=$$INCOME^VAFMON(DFN,DGBTA,1)
- +6 ;If income type is I or V ignore it PAVEL
- if "I^V"[$PIECE(Y,U,2)
- SET Y=U
- +7 ;Set Alternate Income
- if DGBTINCA
- SET Y=$PIECE(DGBTINCA,U,2)_U_$EXTRACT($PIECE(DGBTINCA,U,4))
- +8 ; returns income & source.
- SET X=$PIECE(Y,U)
- SET DGBTIFL=$PIECE(Y,U,2)
- +9 IF X?1N.E!(X<0)
- Begin DoDot:1
- +10 IF X<0
- SET X=0
- +11 SET X2="0$"
- SET X3=8
- DO COMMA^%DTC
- End DoDot:1
- +12 SET DGBTINC=X_U_$GET(DGBTIFL)
- KILL X,X2
- +13 ; finds dependents Vet, Spouse, Children
- SET DGBTDEP=$$DEP^VAFMON(DFN,DGBTA)
- +14 ;Year to be displayed with Income
- SET DGBTDTY=" (Year: "_$$FMTE^XLFDT($EXTRACT(DGBTDTI,1,3)_"0000")_")"
- +15 ; Means test threshold
- SET DGBTMTTH=$$MTTH^DGBTMTTH(DGBTDEP,DGBTDTI)
- +16 ; RX co-pay threshold
- SET DGBTRXTH=+$$THRES^IBARXEU1(DGBTDTI,1,DGBTDEP)
- +17 ; valid income test y/n
- SET DGBTDYFL=$$DAYFLAG^DGBTUTL
- +18 ;
- PREV ; if past claim get SC%, elig.
- +1 IF CHZFLG
- SET X=^DGBT(392,DGBTA,0)
- SET DGBTELG=$PIECE(X,U,3)
- SET DGBTCSC=$PIECE(X,U,4)
- Begin DoDot:1
- +2 ;dbe patch DGBT*1*22 - save division of existing claims
- if $PIECE(X,U,11)
- SET DGBTDIVI=+$PIECE(X,U,11)
- SET DGBTDIVN=$PIECE($GET(^DG(40.8,DGBTDIVI,0)),U,7)
- +3 if DGBTCSC
- SET DGBTCSC=1_U_DGBTCSC
- if 'DGBTCSC
- SET DGBTCSC=0
- +4 if DGBTELG
- SET DGBTELG=DGBTELG_U_$PIECE(^DIC(8,DGBTELG,0),U)
- End DoDot:1
- CERT ; get last BT certification, get date, then get eligibility
- +1 IF $DATA(^DGBT(392.2,"C",DFN))
- Begin DoDot:1
- +2 ;cd=cert date in inverse then external format, ce= eligibility, ca* = amt certified
- +3 SET DGBTCD=$ORDER(^DGBT(392.2,"C",DFN,0))
- SET DGBTCE=$PIECE(^DGBT(392.2,DGBTCD,0),"^",3)
- +4 SET DGBTCA=$PIECE(^DGBT(392.2,DGBTCD,0),"^",4)
- SET Y=9999999-$PIECE(DGBTCD,".")
- +5 ; date conversion, y=cert date (internal)
- XECUTE ^DD("DD")
- +6 SET DGBTCD=Y
- SET X=DGBTCA
- SET X2="0$"
- SET X3=8
- KILL Y
- DO COMMA^%DTC
- SET DGBTCA=X
- KILL X,X2,X3
- End DoDot:1
- APPTS ; search patient file for appointments through claim date (DTI+1), add dates to array DGBTCL
- +1 NEW ERRCODE,DGARRAY,CLIEN,APTDT
- SET DGARRAY("FLDS")="2;3;10;18"
- +2 SET DGARRAY(4)=DFN
- SET I=$$SDAPI^SDAMA301(.DGARRAY)
- +3 ; I<0 = Error, I<0 = # of Records retrieved
- +4 IF I<0
- SET ERRCODE=$ORDER(^TMP($JOB,"SDAMA301",""))
- SET I1=1
- SET DGBTCL("ERROR")=^TMP($JOB,"SDAMA301",ERRCODE)
- +5 IF I>0
- Begin DoDot:1
- +6 SET CLIEN=""
- +7 FOR
- SET CLIEN=$ORDER(^TMP($JOB,"SDAMA301",DFN,CLIEN))
- if 'CLIEN
- QUIT
- Begin DoDot:2
- +8 SET APTDT=DGBTDTI\1
- +9 FOR
- SET APTDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,CLIEN,APTDT))
- if 'APTDT!(APTDT>(DGBTDTI+1))
- QUIT
- Begin DoDot:3
- +10 SET SDATA=^TMP($JOB,"SDAMA301",DFN,CLIEN,APTDT)
- +11 SET DGBTCL(APTDT)=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,CLIEN,APTDT),U,2),";",2)_U_$PIECE($PIECE(SDATA,U,3),";")
- +12 SET DGBTCL(APTDT)=DGBTCL(APTDT)_U_$PIECE($PIECE(SDATA,U,18),";")_U_$PIECE($PIECE(SDATA,U,10),";")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 KILL ^TMP($JOB,"SDAMA301"),DGARRAY,CLIEN,APTDT
- EXIT ; exit routine
- +1 QUIT
- ERR1 ; error condition
- +1 GOTO QUIT^DGBTEND
- QUIT