- 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 Feb 18, 2025@23:38:11 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