Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUPSPRA

XUPSPRA.m

Go to the documentation of this file.
  1. XUPSPRA ;ALB/CMC - Build PRA segment;Aug 6, 2010
  1. ;;8.0;KERNEL;**551,689**;Jul 10, 1995;Build 113
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN(XUPSIEN,XUPSSTR,HL) ;
  1. ;XUPSIEN - New Person Internal Entry Number
  1. ;XUPSSTR - sequence numbers which should be used, only field 6 for DEA# at this point used
  1. ;HL - hl7 array variables
  1. ;RETURN: PRA segment returned or -1^error message
  1. ;
  1. N XUPSREC,NUM
  1. I XUPSIEN=""!(XUPSSTR="")!('$D(HL)) S XUPSREC="-1^Missing Parameters" G QUIT ;missing parameter
  1. S $P(XUPSREC,HL("FS"),1)="PRA" ;sequence 1 set to segment type
  1. ;DEA# FIELD 6
  1. ;S NUM=$P($G(^VA(200,XUPSIEN,"PS")),"^",2)
  1. S NUM=$$PRDEA^XUSER(XUPSIEN)
  1. I NUM="" S NUM=HL("Q")
  1. S $P(XUPSREC,HL("FS"),7)=NUM
  1. QUIT Q XUPSREC
  1. ;
  1. DEAXDT(DEA) ; 689 - Return Expiration Date for DEA
  1. N DEAIEN,RET
  1. Q:'$L($G(DEA)) ""
  1. S DEAIEN=$$FIND1^DIC(8991.9,"","X",DEA)
  1. S RET=$$GET1^DIQ(8991.9,DEAIEN,.04,"I")
  1. Q RET
  1. ;
  1. PRXDT(IEN) ; 689 - called from PRXDT^XUSER
  1. Q:'$D(IEN) ""
  1. N J,K,NP,RET S RET="",NP=0
  1. S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(RET)
  1. . S NP=1,K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I") D:K
  1. .. I $$GET1^DIQ(8991.9,K,.06,"I") S RET=$$GET1^DIQ(8991.9,K,.04,"I")
  1. Q RET
  1. ;
  1. PRDEA(IEN) ; 689 - Called from PRDEA^XUSER
  1. Q:'$D(IEN) ""
  1. N J,K,NP,RET S RET="",NP=0
  1. S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(RET)
  1. . S NP=1,K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I") D:K
  1. .. I $$GET1^DIQ(8991.9,K,.06,"I") S RET=$$GET1^DIQ(8991.9,K,.01)
  1. Q RET
  1. ;
  1. PRSCH(IEN,SCHTYP) ; 689 - Called from PRSCH^XUSER
  1. ; IEN : PROVIDER DUZ
  1. ; SCHTYP : NULL or 0 = First Active DEA Number
  1. ; 1 = Inpatient DEA
  1. ; 2 = First Institutional DEA
  1. Q:'$D(IEN) ""
  1. N J,K,NP,RET,ALTRET,DEACT
  1. S RET="",NP=0,ALTRET=""
  1. ; First Active DEA
  1. I '$G(SCHTYP) S DEACT=$$DEA^XUSER(0,IEN) D Q RET
  1. . N DEAIEN S DEAIEN=$$FIND1^DIC(8991.9,"","X",$P(DEACT,"-")) Q:'DEAIEN
  1. . S RET=$G(^XTV(8991.9,DEAIEN,2))
  1. S J=0 F S J=$O(^VA(200,IEN,"PS4",J)) Q:'J D Q:$L(RET)
  1. . S NP=1,K=$$GET1^DIQ(200.5321,J_","_IEN_",",.03,"I") D:K
  1. .. ; If Individual DEA, find one marked for Inpatient
  1. .. I $G(SCHTYP)=1,$$GET1^DIQ(8991.9,K,.06,"I") S RET=$G(^XTV(8991.9,K,2)) Q
  1. .. ; Get schedules from first Institutional DEA if it exists
  1. .. I $G(SCHTYP)=2 I $$GET1^DIQ(8991.9,K,.07,"I")=1 S RET=$G(^VA(200,IEN,"PS3")) Q
  1. Q RET
  1. ;
  1. DEASCH(DEA) ; 689 - Return DEA schedules for DEA
  1. ; DEA number
  1. N RET,DEAIEN
  1. S RET="",DEAIEN=""
  1. Q:'$L($G(DEA)) RET
  1. S DEAIEN=$$FIND1^DIC(8991.9,"","X",DEA,"B")
  1. Q:DEAIEN'>0 ""
  1. S RET=$G(^XTV(8991.9,DEAIEN,2))
  1. Q RET