RCDMCUT1 ;HEC/SBW - Utility Functions for Hold Debt to DMC Project ;30/AUG/2007
;;4.5;Accounts Receivable;**253,347**;Mar 20, 1995;Build 47
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
HOLDCHK(IEN,DFN) ;Check if receivable shouldn't be sent to DMC
;Dont refer receivables for veterans who are (return 1)
; 1. "DMC Debt Valid" field = NULL and
; SC 50% to 100% or in receipt of VA Pension and "DMC Debt Valid"
; For this case only update DMC Debt Valid Field to Pending
; 2. "DMC Debt Valid" is Pending or NO
;Refer receivables for veterans who are (return 0)
; 1. "DMC Debt Valid" is "YES"
; 2. "DMC Debt Valid" is NULL and
; not SC 50% to 100% and not in receipt of a VA Pensions
;
;INPUT
; IEN - Internal Entry Number for Accounts Recievable File
; DFN - Internal Entry Number to Patient (#2) file
;OUTPUT
; 1 - Don't sent the Debt to DMC
; 0 - Debt can be sent to DMC
;
N OUT,DMCVALID,DMCELIG
S OUT=0
;Quit if invalid IEN or DFN passed
Q:$G(IEN)'>0!($G(DFN)'>0) OUT
;Get DMC Debt Valid field
S DMCVALID=$$GET1^DIQ(430,+$G(IEN)_",",125,"E")
;If DMC Debt Valid is No or Pending don't refer to DMC
S:DMCVALID="NO"!(DMCVALID="PENDING") OUT=1
;If DMC Debt Valid is Yes refer to DMC
S:DMCVALID="YES" OUT=0
;Check if Vet is SC 50% to 100% or in Receipt of VA Pension
S DMCELIG=+$$DMCELIG^RCDMCUT1(+$G(DFN))
;If DMC Debt Valid is Null & SC 50% to 100% or Receiving VA Pension
;refer to DMC
D:DMCVALID=""&(DMCELIG>0)
. S OUT=1
. ;Update DMC Valid Indicator to Pending
. D UPDTDMC^RCDMCUT1(IEN,"P",1)
;If DMC Debt Valid is Null & NOT SC 50%to100% & NOT Receiving VA Pension
;don't refer to DMC
S:DMCVALID=""&(DMCELIG'>0) OUT=0
Q OUT
;
DMCELIG(DFN) ;Checks Bill Debtor SC% and Receipt of VA Pension Values
;INPUT:
; DFN - Pointer Value to Patient (#2) file
;OUTPUT:
; Returns 0 if not SC 50% to 100% and not receiving a VA Pension
; Returns "1^ SC % ^ VA Pension ^ A&A Benefits ^ Housbound Benefits"
; if SC 50% to 100% or Receiving a VA Pension.
; Should also consider Vets who are receiving A&A or
; Housebound benefits as Receiving VA a VA Pension.
; The 2nd piece will be the SC % if SC 50% to 100%.
; The 3rd piece will be a 1 if Receiving a VA Pension.
; If not SC 50% to 100% or Receiving a VA Pension then
; The 4th piece will be the A&A Benefits.
; The 5th piece will be the Housebound Benefits.
;
N OUT
;Protect the VADPT variables to prevent errors with ^RCDMC90 routine
N VAHOW,VAROOT,VAERR,VAEL,VAMB,VADM,VASV,VAPA,VATEST,VAOA,VAINDT,VAIN
N VAIP,VAPD,VARP,VASD,VA,VADMVT
S OUT=0
;Quit if no DFN passed
Q:$G(DFN)'>0 OUT
;Get Eligibility Data
D ELIG^VADPT
;Quit if ^DPT(DFN,0) not defined
Q:$G(VAERR)>0 OUT
;Get monetary benefit data
D MB^VADPT
;SERVICE CONNECTED? Field- If SC the SC% returned in the 2nd piece.
S:$P($G(VAEL(3)),U,2)>49 $P(OUT,U,1)=1,$P(OUT,U,2)=$P(VAEL(3),U,2)
;RECEIVING A VA PENSION?
S:$P($G(VAMB(4)),U,1)>0 $P(OUT,U,1)=1,$P(OUT,U,3)=$P(VAMB(4),U,1)
D:+OUT'>0
. ;RECEIVING A&A BENEFITS?
. S:$P($G(VAMB(1)),U,1)>0 $P(OUT,U,1)=1,$P(OUT,U,4)=$P(VAMB(1),U,1)
. ;RECEIVING HOUSEBOUND BENEFITS?
. S:$P($G(VAMB(2)),U,1)>0 $P(OUT,U,1)=1,$P(OUT,U,5)=$P(VAMB(2),U,1)
D KVAR^VADPT
Q OUT
;
UPDTDMC(IEN,VAL,DELBY) ;Update the DMC Debt Valid Field
;INPUT
; IEN - Internal Entry Number of Accounts Receivable (#430) file
; VAL - DMC Debt Valid Value ("P", "Y", "N" or "@"),
; If "@" pass the field will be deleted
; DELBY - Used to delete the "DMC Debt Valid Edited By" field when
; updated by the Nightly Background Job
;Output
; No output
;
N DA,DIE,DR,X,Y
Q:$G(IEN)'>0
Q:"^Y^N^P^@^"'[(U_$G(VAL)_U)
L +^PRCA(430,IEN,12.1):30
;Quit if another user is editing this entry
I '$T Q
S DA=IEN
S DIE=430
S DR="125////"_VAL
S:$G(DELBY)>0 DR=DR_";126///@"
D ^DIE
L -^PRCA(430,IEN,12.1)
Q
;
GETDEM(DFN) ; Get data from Patient (#2) file
;INPUT:
; DFN - Pointer Value to Patient (#2) file
;OUTPUT:
; DEM^VADPT VADM array as spelled out in PIMS Technical Manual
;
;Calling routines needs to New or Kill following Variables by calling
; D KVAR^VADPT
; VADM,VAERR,VA
;
N OUT,Y
S OUT=0
;Quit if no DFN passed
Q:$G(DFN)'>0 OUT
;Get Demographic Data
D DEM^VADPT
;Quit if ^DPT(DFN,0) not defined
Q:$G(VAERR)>0 OUT
;Calls Successful
S OUT=1
Q OUT
;
FIRSTPAR(IEN430) ;Check if this is a First Party bill
;INPUT
; IEN430 - Internal Entry Number for Accounts Receivable File
;OUTPUT
; Returns a 0 if not First Party Bill
; Returns a 1 if First Party Bill
;
N FLD,FIRST,IEN340
;Set default to zero
S FIRST=0
S IEN430=+$G(IEN430)
;Get DEBTOR Field Value in Account Receivable File
S IEN340=+$P($G(^PRCA(430,IEN430,0)),U,9)
;If .01 field in AR Debtor File points to the Patient file
;then this is a First Party Debt
S FLD=$P($G(^RCD(340,IEN340,0)),U,1)
S:FLD["DPT" FIRST=1_U_$P(FLD,";",1)
Q FIRST
;
GETSERDT(BILLNUM) ; Get most recent Outpatient Date, Inpatient Date and RX Date
; from the IB Action (#350) file for the corresponding bill
;INPUT
; BILLNUM - Bill No. (.01) field in AR (#430) file
;OUTPUT
; 0 - No data
; 1 ^ Outpatient Date ^ Discharge Date ^ RX/Refill Date ^ Status
N OUT,IEN
S OUT=0,IEN=0
;Quit if a Bill Number wasn't passed
Q:$G(BILLNUM)']"" OUT
F S IEN=$O(^IB("ABIL",BILLNUM,IEN)) Q:IEN'>0 D
. N IBDATA,IENS,DFN,ACTTYPE,RESULT,DTBILLFR,BILGROUP,OPDT,DISCHARG,RXDT,STATUS,RXNUM,RXNAM
. S IENS=IEN_","
. D GETS^DIQ(350,IENS,".02;.03;.04;.14","IN","IBDATA")
. S DFN=$G(IBDATA(350,IENS,.02,"I"))
. S ACTTYPE=$G(IBDATA(350,IENS,.03,"I"))
. S RESULT=$G(IBDATA(350,IENS,.04,"I"))
. S DTBILLFR=$G(IBDATA(350,IENS,.14,"I"))
. S STATUS=$$GET1^DIQ(350,IENS,.05)
. ;
. ;Child charge. Need to get Parent Charge
. I $P(RESULT,":",1)=350 D
. . S IENS=+$P(RESULT,":",2)_","
. . ;Quit if the entry is the parent
. . Q:+IENS=IEN
. . D GETS^DIQ(350,IENS,".02;.03;.04;.14","IN","IBDATA")
. . S DFN=$G(IBDATA(350,IENS,.02,"I"))
. . S ACTTYPE=$G(IBDATA(350,IENS,.03,"I"))
. . S RESULT=$G(IBDATA(350,IENS,.04,"I"))
. . S DTBILLFR=$G(IBDATA(350,IENS,.14,"I"))
. . S STATUS=$$GET1^DIQ(350,IENS,.05)
. Q:$G(DFN)']""
. ;
. ;Get Billing Group in the IB Action Type File. If internal Set
. ;Code value is 4, then this is an Outpatient Visit (From STMT^IBRFN1)
. ;and can use Date Billed From for the Outpatient Visit Date
. S BILGROUP=$$GET1^DIQ(350.1,+ACTTYPE_",",.11,"I")
. ;
. ;Outpatient Event
. I BILGROUP=4!($P(RESULT,":",1)=44)!($P(RESULT,":",1)=409.68) D Q
. . I $P(RESULT,":",1)=44 S OPDT=$P($P(RESULT,";",2),":",2)
. . I $P(RESULT,":",1)=409.68 S OPDT=$$GET1^DIQ(409.68,+$P(RESULT,":",2)_",",.01,"I")
. . I $G(OPDT)'>0 S OPDT=DTBILLFR
. . I $G(OPDT)>$P(OUT,U,2) S $P(OUT,U,1)=1,$P(OUT,U,2)=OPDT,$P(OUT,U,5)=STATUS
. ;
. ;Quit if RESULTING FROM field is blank
. Q:$G(RESULT)']""
. ;
. ;Inpatient Event
. I $P(RESULT,":",1)=405!($P(RESULT,":",1)=45) D Q
. . S VAIP("E")=$P($P(RESULT,";",1),":",2)
. . ;Call to get Inpatient data
. . D IN5^VADPT
. . Q:VAERR>0
. . S DISCHARG=$P($G(VAIP(17,1)),U,1)
. . ;Ensure get most current Discharge Date
. . I DISCHARG>$P(OUT,U,3) S $P(OUT,U,1)=1,$P(OUT,U,3)=DISCHARG,$P(OUT,U,5)=STATUS
. . D KVAR^VADPT
. ;
. ;RX Event
. I $P(RESULT,":",1)=52 D Q
. . N PSOFILE,IENS,FLD
. . ;Set up for RX Refills
. . I $P(RESULT,";",2)]"" D
. . . S PSOFILE=52.1
. . . S IENS=+$P($P(RESULT,";",2),":",2)_","_+$P($P(RESULT,";",1),":",2)_","
. . . S RXDT=$$GET1^PSODI(PSOFILE,IENS,.01,"I")
. . . S RXNAM="1^TBD",RXNUM="1^TBD"
. . ;Set up for RX Data (No refill)
. . I $P(RESULT,";",2)']"" D
. . . S PSOFILE=52
. . . S IENS=+$P($P(RESULT,";",1),":",2)_","
. . . S RXDT=$$GET1^PSODI(PSOFILE,IENS,1,"I")
. . . S RXNUM=$$GET1^PSODI(PSOFILE,IENS,.01,"I")
. . . S RXNAM=$$GET1^PSODI(PSOFILE,IENS,6,"E")
. . ;Ensure get most current RX/Refill Date
. . I RXDT>$P(OUT,U,4) S $P(OUT,U,1)=1,$P(OUT,U,4)=$P(RXDT,U,2),$P(OUT,U,5)=STATUS,$P(OUT,U,6)=$P(RXNUM,U,2),$P(OUT,U,7)=$P(RXNAM,U,2)
Q OUT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMCUT1 8296 printed Dec 13, 2024@01:43:45 Page 2
RCDMCUT1 ;HEC/SBW - Utility Functions for Hold Debt to DMC Project ;30/AUG/2007
+1 ;;4.5;Accounts Receivable;**253,347**;Mar 20, 1995;Build 47
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
HOLDCHK(IEN,DFN) ;Check if receivable shouldn't be sent to DMC
+1 ;Dont refer receivables for veterans who are (return 1)
+2 ; 1. "DMC Debt Valid" field = NULL and
+3 ; SC 50% to 100% or in receipt of VA Pension and "DMC Debt Valid"
+4 ; For this case only update DMC Debt Valid Field to Pending
+5 ; 2. "DMC Debt Valid" is Pending or NO
+6 ;Refer receivables for veterans who are (return 0)
+7 ; 1. "DMC Debt Valid" is "YES"
+8 ; 2. "DMC Debt Valid" is NULL and
+9 ; not SC 50% to 100% and not in receipt of a VA Pensions
+10 ;
+11 ;INPUT
+12 ; IEN - Internal Entry Number for Accounts Recievable File
+13 ; DFN - Internal Entry Number to Patient (#2) file
+14 ;OUTPUT
+15 ; 1 - Don't sent the Debt to DMC
+16 ; 0 - Debt can be sent to DMC
+17 ;
+18 NEW OUT,DMCVALID,DMCELIG
+19 SET OUT=0
+20 ;Quit if invalid IEN or DFN passed
+21 if $GET(IEN)'>0!($GET(DFN)'>0)
QUIT OUT
+22 ;Get DMC Debt Valid field
+23 SET DMCVALID=$$GET1^DIQ(430,+$GET(IEN)_",",125,"E")
+24 ;If DMC Debt Valid is No or Pending don't refer to DMC
+25 if DMCVALID="NO"!(DMCVALID="PENDING")
SET OUT=1
+26 ;If DMC Debt Valid is Yes refer to DMC
+27 if DMCVALID="YES"
SET OUT=0
+28 ;Check if Vet is SC 50% to 100% or in Receipt of VA Pension
+29 SET DMCELIG=+$$DMCELIG^RCDMCUT1(+$GET(DFN))
+30 ;If DMC Debt Valid is Null & SC 50% to 100% or Receiving VA Pension
+31 ;refer to DMC
+32 if DMCVALID=""&(DMCELIG>0)
Begin DoDot:1
+33 SET OUT=1
+34 ;Update DMC Valid Indicator to Pending
+35 DO UPDTDMC^RCDMCUT1(IEN,"P",1)
End DoDot:1
+36 ;If DMC Debt Valid is Null & NOT SC 50%to100% & NOT Receiving VA Pension
+37 ;don't refer to DMC
+38 if DMCVALID=""&(DMCELIG'>0)
SET OUT=0
+39 QUIT OUT
+40 ;
DMCELIG(DFN) ;Checks Bill Debtor SC% and Receipt of VA Pension Values
+1 ;INPUT:
+2 ; DFN - Pointer Value to Patient (#2) file
+3 ;OUTPUT:
+4 ; Returns 0 if not SC 50% to 100% and not receiving a VA Pension
+5 ; Returns "1^ SC % ^ VA Pension ^ A&A Benefits ^ Housbound Benefits"
+6 ; if SC 50% to 100% or Receiving a VA Pension.
+7 ; Should also consider Vets who are receiving A&A or
+8 ; Housebound benefits as Receiving VA a VA Pension.
+9 ; The 2nd piece will be the SC % if SC 50% to 100%.
+10 ; The 3rd piece will be a 1 if Receiving a VA Pension.
+11 ; If not SC 50% to 100% or Receiving a VA Pension then
+12 ; The 4th piece will be the A&A Benefits.
+13 ; The 5th piece will be the Housebound Benefits.
+14 ;
+15 NEW OUT
+16 ;Protect the VADPT variables to prevent errors with ^RCDMC90 routine
+17 NEW VAHOW,VAROOT,VAERR,VAEL,VAMB,VADM,VASV,VAPA,VATEST,VAOA,VAINDT,VAIN
+18 NEW VAIP,VAPD,VARP,VASD,VA,VADMVT
+19 SET OUT=0
+20 ;Quit if no DFN passed
+21 if $GET(DFN)'>0
QUIT OUT
+22 ;Get Eligibility Data
+23 DO ELIG^VADPT
+24 ;Quit if ^DPT(DFN,0) not defined
+25 if $GET(VAERR)>0
QUIT OUT
+26 ;Get monetary benefit data
+27 DO MB^VADPT
+28 ;SERVICE CONNECTED? Field- If SC the SC% returned in the 2nd piece.
+29 if $PIECE($GET(VAEL(3)),U,2)>49
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,2)=$PIECE(VAEL(3),U,2)
+30 ;RECEIVING A VA PENSION?
+31 if $PIECE($GET(VAMB(4)),U,1)>0
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,3)=$PIECE(VAMB(4),U,1)
+32 if +OUT'>0
Begin DoDot:1
+33 ;RECEIVING A&A BENEFITS?
+34 if $PIECE($GET(VAMB(1)),U,1)>0
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,4)=$PIECE(VAMB(1),U,1)
+35 ;RECEIVING HOUSEBOUND BENEFITS?
+36 if $PIECE($GET(VAMB(2)),U,1)>0
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,5)=$PIECE(VAMB(2),U,1)
End DoDot:1
+37 DO KVAR^VADPT
+38 QUIT OUT
+39 ;
UPDTDMC(IEN,VAL,DELBY) ;Update the DMC Debt Valid Field
+1 ;INPUT
+2 ; IEN - Internal Entry Number of Accounts Receivable (#430) file
+3 ; VAL - DMC Debt Valid Value ("P", "Y", "N" or "@"),
+4 ; If "@" pass the field will be deleted
+5 ; DELBY - Used to delete the "DMC Debt Valid Edited By" field when
+6 ; updated by the Nightly Background Job
+7 ;Output
+8 ; No output
+9 ;
+10 NEW DA,DIE,DR,X,Y
+11 if $GET(IEN)'>0
QUIT
+12 if "^Y^N^P^@^"'[(U_$GET(VAL)_U)
QUIT
+13 LOCK +^PRCA(430,IEN,12.1):30
+14 ;Quit if another user is editing this entry
+15 IF '$TEST
QUIT
+16 SET DA=IEN
+17 SET DIE=430
+18 SET DR="125////"_VAL
+19 if $GET(DELBY)>0
SET DR=DR_";126///@"
+20 DO ^DIE
+21 LOCK -^PRCA(430,IEN,12.1)
+22 QUIT
+23 ;
GETDEM(DFN) ; Get data from Patient (#2) file
+1 ;INPUT:
+2 ; DFN - Pointer Value to Patient (#2) file
+3 ;OUTPUT:
+4 ; DEM^VADPT VADM array as spelled out in PIMS Technical Manual
+5 ;
+6 ;Calling routines needs to New or Kill following Variables by calling
+7 ; D KVAR^VADPT
+8 ; VADM,VAERR,VA
+9 ;
+10 NEW OUT,Y
+11 SET OUT=0
+12 ;Quit if no DFN passed
+13 if $GET(DFN)'>0
QUIT OUT
+14 ;Get Demographic Data
+15 DO DEM^VADPT
+16 ;Quit if ^DPT(DFN,0) not defined
+17 if $GET(VAERR)>0
QUIT OUT
+18 ;Calls Successful
+19 SET OUT=1
+20 QUIT OUT
+21 ;
FIRSTPAR(IEN430) ;Check if this is a First Party bill
+1 ;INPUT
+2 ; IEN430 - Internal Entry Number for Accounts Receivable File
+3 ;OUTPUT
+4 ; Returns a 0 if not First Party Bill
+5 ; Returns a 1 if First Party Bill
+6 ;
+7 NEW FLD,FIRST,IEN340
+8 ;Set default to zero
+9 SET FIRST=0
+10 SET IEN430=+$GET(IEN430)
+11 ;Get DEBTOR Field Value in Account Receivable File
+12 SET IEN340=+$PIECE($GET(^PRCA(430,IEN430,0)),U,9)
+13 ;If .01 field in AR Debtor File points to the Patient file
+14 ;then this is a First Party Debt
+15 SET FLD=$PIECE($GET(^RCD(340,IEN340,0)),U,1)
+16 if FLD["DPT"
SET FIRST=1_U_$PIECE(FLD,";",1)
+17 QUIT FIRST
+18 ;
GETSERDT(BILLNUM) ; Get most recent Outpatient Date, Inpatient Date and RX Date
+1 ; from the IB Action (#350) file for the corresponding bill
+2 ;INPUT
+3 ; BILLNUM - Bill No. (.01) field in AR (#430) file
+4 ;OUTPUT
+5 ; 0 - No data
+6 ; 1 ^ Outpatient Date ^ Discharge Date ^ RX/Refill Date ^ Status
+7 NEW OUT,IEN
+8 SET OUT=0
SET IEN=0
+9 ;Quit if a Bill Number wasn't passed
+10 if $GET(BILLNUM)']""
QUIT OUT
+11 FOR
SET IEN=$ORDER(^IB("ABIL",BILLNUM,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+12 NEW IBDATA,IENS,DFN,ACTTYPE,RESULT,DTBILLFR,BILGROUP,OPDT,DISCHARG,RXDT,STATUS,RXNUM,RXNAM
+13 SET IENS=IEN_","
+14 DO GETS^DIQ(350,IENS,".02;.03;.04;.14","IN","IBDATA")
+15 SET DFN=$GET(IBDATA(350,IENS,.02,"I"))
+16 SET ACTTYPE=$GET(IBDATA(350,IENS,.03,"I"))
+17 SET RESULT=$GET(IBDATA(350,IENS,.04,"I"))
+18 SET DTBILLFR=$GET(IBDATA(350,IENS,.14,"I"))
+19 SET STATUS=$$GET1^DIQ(350,IENS,.05)
+20 ;
+21 ;Child charge. Need to get Parent Charge
+22 IF $PIECE(RESULT,":",1)=350
Begin DoDot:2
+23 SET IENS=+$PIECE(RESULT,":",2)_","
+24 ;Quit if the entry is the parent
+25 if +IENS=IEN
QUIT
+26 DO GETS^DIQ(350,IENS,".02;.03;.04;.14","IN","IBDATA")
+27 SET DFN=$GET(IBDATA(350,IENS,.02,"I"))
+28 SET ACTTYPE=$GET(IBDATA(350,IENS,.03,"I"))
+29 SET RESULT=$GET(IBDATA(350,IENS,.04,"I"))
+30 SET DTBILLFR=$GET(IBDATA(350,IENS,.14,"I"))
+31 SET STATUS=$$GET1^DIQ(350,IENS,.05)
End DoDot:2
+32 if $GET(DFN)']""
QUIT
+33 ;
+34 ;Get Billing Group in the IB Action Type File. If internal Set
+35 ;Code value is 4, then this is an Outpatient Visit (From STMT^IBRFN1)
+36 ;and can use Date Billed From for the Outpatient Visit Date
+37 SET BILGROUP=$$GET1^DIQ(350.1,+ACTTYPE_",",.11,"I")
+38 ;
+39 ;Outpatient Event
+40 IF BILGROUP=4!($PIECE(RESULT,":",1)=44)!($PIECE(RESULT,":",1)=409.68)
Begin DoDot:2
+41 IF $PIECE(RESULT,":",1)=44
SET OPDT=$PIECE($PIECE(RESULT,";",2),":",2)
+42 IF $PIECE(RESULT,":",1)=409.68
SET OPDT=$$GET1^DIQ(409.68,+$PIECE(RESULT,":",2)_",",.01,"I")
+43 IF $GET(OPDT)'>0
SET OPDT=DTBILLFR
+44 IF $GET(OPDT)>$PIECE(OUT,U,2)
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,2)=OPDT
SET $PIECE(OUT,U,5)=STATUS
End DoDot:2
QUIT
+45 ;
+46 ;Quit if RESULTING FROM field is blank
+47 if $GET(RESULT)']""
QUIT
+48 ;
+49 ;Inpatient Event
+50 IF $PIECE(RESULT,":",1)=405!($PIECE(RESULT,":",1)=45)
Begin DoDot:2
+51 SET VAIP("E")=$PIECE($PIECE(RESULT,";",1),":",2)
+52 ;Call to get Inpatient data
+53 DO IN5^VADPT
+54 if VAERR>0
QUIT
+55 SET DISCHARG=$PIECE($GET(VAIP(17,1)),U,1)
+56 ;Ensure get most current Discharge Date
+57 IF DISCHARG>$PIECE(OUT,U,3)
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,3)=DISCHARG
SET $PIECE(OUT,U,5)=STATUS
+58 DO KVAR^VADPT
End DoDot:2
QUIT
+59 ;
+60 ;RX Event
+61 IF $PIECE(RESULT,":",1)=52
Begin DoDot:2
+62 NEW PSOFILE,IENS,FLD
+63 ;Set up for RX Refills
+64 IF $PIECE(RESULT,";",2)]""
Begin DoDot:3
+65 SET PSOFILE=52.1
+66 SET IENS=+$PIECE($PIECE(RESULT,";",2),":",2)_","_+$PIECE($PIECE(RESULT,";",1),":",2)_","
+67 SET RXDT=$$GET1^PSODI(PSOFILE,IENS,.01,"I")
+68 SET RXNAM="1^TBD"
SET RXNUM="1^TBD"
End DoDot:3
+69 ;Set up for RX Data (No refill)
+70 IF $PIECE(RESULT,";",2)']""
Begin DoDot:3
+71 SET PSOFILE=52
+72 SET IENS=+$PIECE($PIECE(RESULT,";",1),":",2)_","
+73 SET RXDT=$$GET1^PSODI(PSOFILE,IENS,1,"I")
+74 SET RXNUM=$$GET1^PSODI(PSOFILE,IENS,.01,"I")
+75 SET RXNAM=$$GET1^PSODI(PSOFILE,IENS,6,"E")
End DoDot:3
+76 ;Ensure get most current RX/Refill Date
+77 IF RXDT>$PIECE(OUT,U,4)
SET $PIECE(OUT,U,1)=1
SET $PIECE(OUT,U,4)=$PIECE(RXDT,U,2)
SET $PIECE(OUT,U,5)=STATUS
SET $PIECE(OUT,U,6)=$PIECE(RXNUM,U,2)
SET $PIECE(OUT,U,7)=$PIECE(RXNAM,U,2)
End DoDot:2
QUIT
End DoDot:1
+78 QUIT OUT
+79 ;
