XUPSPRA ;ALB/CMC - Build PRA segment;Aug 6, 2010
;;8.0;KERNEL;**551,689**;Jul 10, 1995;Build 113
;;Per VA Directive 6402, this routine should not be modified.
;
EN(XUPSIEN,XUPSSTR,HL) ;
;XUPSIEN - New Person Internal Entry Number
;XUPSSTR - sequence numbers which should be used, only field 6 for DEA# at this point used
;HL - hl7 array variables
;RETURN: PRA segment returned or -1^error message
;
N XUPSREC,NUM
I XUPSIEN=""!(XUPSSTR="")!('$D(HL)) S XUPSREC="-1^Missing Parameters" G QUIT ;missing parameter
S $P(XUPSREC,HL("FS"),1)="PRA" ;sequence 1 set to segment type
;DEA# FIELD 6
;S NUM=$P($G(^VA(200,XUPSIEN,"PS")),"^",2)
S NUM=$$PRDEA^XUSER(XUPSIEN)
I NUM="" S NUM=HL("Q")
S $P(XUPSREC,HL("FS"),7)=NUM
QUIT Q XUPSREC
;
DEAXDT(DEA) ; 689 - Return Expiration Date for DEA
N DEAIEN,RET
Q:'$L($G(DEA)) ""
S DEAIEN=$$FIND1^DIC(8991.9,"","X",DEA)
S RET=$$GET1^DIQ(8991.9,DEAIEN,.04,"I")
Q RET
;
PRXDT(IEN) ; 689 - called from PRXDT^XUSER
Q:'$D(IEN) ""
N J,K,NP,RET S RET="",NP=0
S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(RET)
. S NP=1,K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I") D:K
.. I $$GET1^DIQ(8991.9,K,.06,"I") S RET=$$GET1^DIQ(8991.9,K,.04,"I")
Q RET
;
PRDEA(IEN) ; 689 - Called from PRDEA^XUSER
Q:'$D(IEN) ""
N J,K,NP,RET S RET="",NP=0
S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(RET)
. S NP=1,K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I") D:K
.. I $$GET1^DIQ(8991.9,K,.06,"I") S RET=$$GET1^DIQ(8991.9,K,.01)
Q RET
;
PRSCH(IEN,SCHTYP) ; 689 - Called from PRSCH^XUSER
; IEN : PROVIDER DUZ
; SCHTYP : NULL or 0 = First Active DEA Number
; 1 = Inpatient DEA
; 2 = First Institutional DEA
Q:'$D(IEN) ""
N J,K,NP,RET,ALTRET,DEACT
S RET="",NP=0,ALTRET=""
; First Active DEA
I '$G(SCHTYP) S DEACT=$$DEA^XUSER(0,IEN) D Q RET
. N DEAIEN S DEAIEN=$$FIND1^DIC(8991.9,"","X",$P(DEACT,"-")) Q:'DEAIEN
. S RET=$G(^XTV(8991.9,DEAIEN,2))
S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(RET)
. S NP=1,K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I") D:K
.. ; If Individual DEA, find one marked for Inpatient
.. I $G(SCHTYP)=1,$$GET1^DIQ(8991.9,K,.06,"I") S RET=$G(^XTV(8991.9,K,2)) Q
.. ; Get schedules from first Institutional DEA if it exists
.. I $G(SCHTYP)=2 I $$GET1^DIQ(8991.9,K,.07,"I")=1 S RET=$G(^VA(200,IEN,"PS3")) Q
Q RET
;
DEASCH(DEA) ; 689 - Return DEA schedules for DEA
; DEA number
N RET,DEAIEN
S RET="",DEAIEN=""
Q:'$L($G(DEA)) RET
S DEAIEN=$$FIND1^DIC(8991.9,"","X",DEA,"B")
Q:DEAIEN'>0 ""
S RET=$G(^XTV(8991.9,DEAIEN,2))
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPSPRA 2645 printed Sep 23, 2025@19:48 Page 2
XUPSPRA ;ALB/CMC - Build PRA segment;Aug 6, 2010
+1 ;;8.0;KERNEL;**551,689**;Jul 10, 1995;Build 113
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN(XUPSIEN,XUPSSTR,HL) ;
+1 ;XUPSIEN - New Person Internal Entry Number
+2 ;XUPSSTR - sequence numbers which should be used, only field 6 for DEA# at this point used
+3 ;HL - hl7 array variables
+4 ;RETURN: PRA segment returned or -1^error message
+5 ;
+6 NEW XUPSREC,NUM
+7 ;missing parameter
IF XUPSIEN=""!(XUPSSTR="")!('$DATA(HL))
SET XUPSREC="-1^Missing Parameters"
GOTO QUIT
+8 ;sequence 1 set to segment type
SET $PIECE(XUPSREC,HL("FS"),1)="PRA"
+9 ;DEA# FIELD 6
+10 ;S NUM=$P($G(^VA(200,XUPSIEN,"PS")),"^",2)
+11 SET NUM=$$PRDEA^XUSER(XUPSIEN)
+12 IF NUM=""
SET NUM=HL("Q")
+13 SET $PIECE(XUPSREC,HL("FS"),7)=NUM
QUIT QUIT XUPSREC
+1 ;
DEAXDT(DEA) ; 689 - Return Expiration Date for DEA
+1 NEW DEAIEN,RET
+2 if '$LENGTH($GET(DEA))
QUIT ""
+3 SET DEAIEN=$$FIND1^DIC(8991.9,"","X",DEA)
+4 SET RET=$$GET1^DIQ(8991.9,DEAIEN,.04,"I")
+5 QUIT RET
+6 ;
PRXDT(IEN) ; 689 - called from PRXDT^XUSER
+1 if '$DATA(IEN)
QUIT ""
+2 NEW J,K,NP,RET
SET RET=""
SET NP=0
+3 SET J=0
FOR
SET J=$ORDER(^VA(200,IEN,"PS4",J))
if 'J
QUIT
Begin DoDot:1
+4 SET NP=1
SET K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I")
if K
Begin DoDot:2
+5 IF $$GET1^DIQ(8991.9,K,.06,"I")
SET RET=$$GET1^DIQ(8991.9,K,.04,"I")
End DoDot:2
End DoDot:1
if $LENGTH(RET)
QUIT
+6 QUIT RET
+7 ;
PRDEA(IEN) ; 689 - Called from PRDEA^XUSER
+1 if '$DATA(IEN)
QUIT ""
+2 NEW J,K,NP,RET
SET RET=""
SET NP=0
+3 SET J=0
FOR
SET J=$ORDER(^VA(200,IEN,"PS4",J))
if 'J
QUIT
Begin DoDot:1
+4 SET NP=1
SET K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I")
if K
Begin DoDot:2
+5 IF $$GET1^DIQ(8991.9,K,.06,"I")
SET RET=$$GET1^DIQ(8991.9,K,.01)
End DoDot:2
End DoDot:1
if $LENGTH(RET)
QUIT
+6 QUIT RET
+7 ;
PRSCH(IEN,SCHTYP) ; 689 - Called from PRSCH^XUSER
+1 ; IEN : PROVIDER DUZ
+2 ; SCHTYP : NULL or 0 = First Active DEA Number
+3 ; 1 = Inpatient DEA
+4 ; 2 = First Institutional DEA
+5 if '$DATA(IEN)
QUIT ""
+6 NEW J,K,NP,RET,ALTRET,DEACT
+7 SET RET=""
SET NP=0
SET ALTRET=""
+8 ; First Active DEA
+9 IF '$GET(SCHTYP)
SET DEACT=$$DEA^XUSER(0,IEN)
Begin DoDot:1
+10 NEW DEAIEN
SET DEAIEN=$$FIND1^DIC(8991.9,"","X",$PIECE(DEACT,"-"))
if 'DEAIEN
QUIT
+11 SET RET=$GET(^XTV(8991.9,DEAIEN,2))
End DoDot:1
QUIT RET
+12 SET J=0
FOR
SET J=$ORDER(^VA(200,IEN,"PS4",J))
if 'J
QUIT
Begin DoDot:1
+13 SET NP=1
SET K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I")
if K
Begin DoDot:2
+14 ; If Individual DEA, find one marked for Inpatient
+15 IF $GET(SCHTYP)=1
IF $$GET1^DIQ(8991.9,K,.06,"I")
SET RET=$GET(^XTV(8991.9,K,2))
QUIT
+16 ; Get schedules from first Institutional DEA if it exists
+17 IF $GET(SCHTYP)=2
IF $$GET1^DIQ(8991.9,K,.07,"I")=1
SET RET=$GET(^VA(200,IEN,"PS3"))
QUIT
End DoDot:2
End DoDot:1
if $LENGTH(RET)
QUIT
+18 QUIT RET
+19 ;
DEASCH(DEA) ; 689 - Return DEA schedules for DEA
+1 ; DEA number
+2 NEW RET,DEAIEN
+3 SET RET=""
SET DEAIEN=""
+4 if '$LENGTH($GET(DEA))
QUIT RET
+5 SET DEAIEN=$$FIND1^DIC(8991.9,"","X",DEA,"B")
+6 if DEAIEN'>0
QUIT ""
+7 SET RET=$GET(^XTV(8991.9,DEAIEN,2))
+8 QUIT RET
