VASITE ;ALB/AAS - TIME SENSETIVE VA STATION NUMBER UTILITY ; [ 04/01/2004 5:17 PM ]
;;5.3;Registration;**134,1004,1009,1012,1013**;Aug 13, 1993
;IHS/ANMC/LJF 7/31/2001 used IHS location file info
;IHS/OIT/LJF 11/09/2005 PATCH 1004 added to patch for sites where good copy was overwritten
;cmi/anch/maw 04/07/2008 PATCH 1009 requirement 54 added fix for no DUZ(2) in SITE
;
SITE(DATE,DIV) ;
; -Output= Institution file pointer^Institution name^station number with suffix
;
; -Input (optional) date for division, if undefined will use DT
; - (optional) medical center division=pointer in 40.8
;
;IHS/ANMC/LJF 7/31/2001 use IHS location file for data
;I '$G(DIV) S DIV=+$O(^DG(40.8,"C",DUZ(2),0)) ;cmi/maw 04/07/2008 patch 1009 orig line
;I '$G(DIV),$G(DUZ(2)) S DIV=+$O(^DG(40.8,"C",DUZ(2),0)) ;cmi/maw 04/07/2008 patch 1009 modified to check for DUZ(2)
I '$G(DIV),$G(DUZ(2)) S DIV=+$O(^DG(40.8,"AD",DUZ(2),0)) ;cmi/maw 04/07/2008 patch 1012 modified to check for "AD" DUZ(2)
;I '$G(DIV) S DIV=+$O(^DG(40.8,"C",$G(^DD("SITE",1)),0)) ;cmi/maw 04/07/2008 patch 1009 modified if neither DUZ(2) or DIV are set
I '$G(DIV) S DIV=+$O(^DG(40.8,"AD",$G(^DD("SITE",1)),0)) ;cmi/maw 04/07/2008 patch 1012 modified if neither DUZ(2) or DIV are set
NEW X S X=$$GET1^DIQ(40.8,+$G(DIV),.07,"I") I 'X Q -1
;Q X_U_$$GET1^DIQ(9999999.06,X,.01)_U_$$GET1^DIQ(9999999.06,X,.0799)
Q X_U_$$GET1^DIQ(9999999.06,X,.01)_U_$$GET1^DIQ(4,X,99) ;IHS/ITSC/LJF 4/1/2004
;IHS/ANMC/LJF 7/31/2001 end of IHS code
;
N PRIM,SITE
S:'$D(DATE) DATE=DT
S:'$D(DIV) DIV=$$PRIM(DATE)
I DATE'?7N!DIV<0 Q -1
S PRIM=$G(^VA(389.9,+$O(^(+$O(^VA(389.9,"AIVDT",DIV,$$IVDATE(DATE))),0)),0))
S SITE=$S('$P(PRIM,"^",6)&($P(PRIM,"^",4)?3N.AN):$P(PRIM,"^",4),1:-1) ;IHS/ANMC/LJF 9/21/2000
S:SITE>0 SITE=$P(^DG(40.8,DIV,0),"^",7)_"^"_$P($G(^DIC(4,$P(^DG(40.8,DIV,0),"^",7),0)),"^")_"^"_SITE
Q SITE
;
ALL(DATE) ; -returns all possible station numbers
; -input date, if date is undefined, then date will be today
; - output VASITE= 1 or -1 if stations exist
; VASITE(station number)=station number
;
N PRIM,DIV
S:'$D(DATE) DATE=DT
S VASITE=-1
;S DIV=0 F S DIV=$O(^VA(389.9,"C",DIV)) Q:'DIV S PRIM=$G(^VA(389.9,+$O(^(+$O(^VA(389.9,"AIVDT",DIV,$$IVDATE(DATE))),0)),0)) S:'$P(PRIM,"^",6)&($P(PRIM,"^",4)?3N) VASITE($P(PRIM,"^",4))=$P(PRIM,"^",4),VASITE=1 ;IHS/ANMC/LJF 9/21/2000
S DIV=0 F S DIV=$O(^VA(389.9,"C",DIV)) Q:'DIV S PRIM=$G(^VA(389.9,+$O(^(+$O(^VA(389.9,"AIVDT",DIV,$$IVDATE(DATE))),0)),0)) S:'$P(PRIM,"^",6)&($P(PRIM,"^",4)?6N) VASITE($P(PRIM,"^",4))=$P(PRIM,"^",4),VASITE=1 ;IHS/ANMC/LJF 9/21/2000
Q VASITE
;
IVDATE(DATE) ; -- inverse date reference start
Q -(DATE+.000001)
;
CHK ; -input transform for IS PRIMARY STATION? field
; -only 1 primary station number allowed per effective date
;
I '$P(^VA(389.9,DA,0),"^",2) W !,"Effective Date must be entered first" K X G CHKQ
I '$P(^VA(389.9,DA,0),"^",3) W !,"Medical Center Division must be entered first.",! K X G CHKQ
I $D(^VA(389.9,"AIVDT1",1,-X)) W !,"Another entry Is Primary Division for this date.",! K X G CHKQ
I 1
CHKQ I 0 Q
;
YN ; -input transform for is primary facility
I '$P(^VA(389.9,DA,0),"^",2) W !,"Effective date must be entered first!" K X Q
I '$P(^VA(389.9,DA,0),"^",3) W !,"Medical Center Division must be entered first!" K X Q
I $D(^VA(389.9,"AIVDT1",1,-$P(^VA(389.9,DA,0),"^",2))) W !,"Only one division can be primary division for an effective date!" K X Q
S X=$E(X),X=$S(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2) I X'=2 W " (",$S(X:"YES",1:"NO"),")" Q
W !?4,"NOT A VALID CHOICE!",*7 K X Q
;
PRIM(DATE) ; -returns medical center division of primary medical center division
; - input date, if date is null then date will be today
;
;Q +$O(^DG(40.8,"C",DUZ(2),0)) ;IHS/ANMC/LJF 7/31/2001
Q +$O(^DG(40.8,"AD",DUZ(2),0)) ;cmi/maw 3/9/2010 PATCH 1012 for station number
N PRIM
S:'$D(DATE) DATE=DT S DATE=DATE+.24
S PRIM=$G(^VA(389.9,+$O(^(+$O(^VA(389.9,"AIVDT1",1,$$IVDATE(DATE))),0)),0))
Q $S($P(PRIM,"^",4)?3N:$P(PRIM,"^",3),1:-1)
;
NAME(DATE) ; -returns the new name of medical centers that have integrated
;
; -input date, if date is null then date will be today
S:'$D(DATE) DATE=DT S DATE=DATE+.24
Q $G(^VA(389.9,+$O(^(+$O(^VA(389.9,"AIVDT1",1,$$IVDATE(DATE))),0)),"INTEG"))
VASITE ;ALB/AAS - TIME SENSETIVE VA STATION NUMBER UTILITY ; [ 04/01/2004 5:17 PM ]
+1 ;;5.3;Registration;**134,1004,1009,1012,1013**;Aug 13, 1993
+2 ;IHS/ANMC/LJF 7/31/2001 used IHS location file info
+3 ;IHS/OIT/LJF 11/09/2005 PATCH 1004 added to patch for sites where good copy was overwritten
+4 ;cmi/anch/maw 04/07/2008 PATCH 1009 requirement 54 added fix for no DUZ(2) in SITE
+5 ;
SITE(DATE,DIV) ;
+1 ; -Output= Institution file pointer^Institution name^station number with suffix
+2 ;
+3 ; -Input (optional) date for division, if undefined will use DT
+4 ; - (optional) medical center division=pointer in 40.8
+5 ;
+6 ;IHS/ANMC/LJF 7/31/2001 use IHS location file for data
+7 ;I '$G(DIV) S DIV=+$O(^DG(40.8,"C",DUZ(2),0)) ;cmi/maw 04/07/2008 patch 1009 orig line
+8 ;I '$G(DIV),$G(DUZ(2)) S DIV=+$O(^DG(40.8,"C",DUZ(2),0)) ;cmi/maw 04/07/2008 patch 1009 modified to check for DUZ(2)
+9 ;cmi/maw 04/07/2008 patch 1012 modified to check for "AD" DUZ(2)
IF '$GET(DIV)
IF $GET(DUZ(2))
SET DIV=+$ORDER(^DG(40.8,"AD",DUZ(2),0))
+10 ;I '$G(DIV) S DIV=+$O(^DG(40.8,"C",$G(^DD("SITE",1)),0)) ;cmi/maw 04/07/2008 patch 1009 modified if neither DUZ(2) or DIV are set
+11 ;cmi/maw 04/07/2008 patch 1012 modified if neither DUZ(2) or DIV are set
IF '$GET(DIV)
SET DIV=+$ORDER(^DG(40.8,"AD",$GET(^DD("SITE",1)),0))
+12 NEW X
SET X=$$GET1^DIQ(40.8,+$GET(DIV),.07,"I")
IF 'X
QUIT -1
+13 ;Q X_U_$$GET1^DIQ(9999999.06,X,.01)_U_$$GET1^DIQ(9999999.06,X,.0799)
+14 ;IHS/ITSC/LJF 4/1/2004
QUIT X_U_$$GET1^DIQ(9999999.06,X,.01)_U_$$GET1^DIQ(4,X,99)
+15 ;IHS/ANMC/LJF 7/31/2001 end of IHS code
+16 ;
+17 NEW PRIM,SITE
+18 IF '$DATA(DATE)
SET DATE=DT
+19 IF '$DATA(DIV)
SET DIV=$$PRIM(DATE)
+20 IF DATE'?7N!DIV<0
QUIT -1
+21 SET PRIM=$GET(^VA(389.9,+$ORDER(^(+$ORDER(^VA(389.9,"AIVDT",DIV,$$IVDATE(DATE))),0)),0))
+22 ;IHS/ANMC/LJF 9/21/2000
SET SITE=$SELECT('$PIECE(PRIM,"^",6)&($PIECE(PRIM,"^",4)?3N.AN):$PIECE(PRIM,"^",4),1:-1)
+23 IF SITE>0
SET SITE=$PIECE(^DG(40.8,DIV,0),"^",7)_"^"_$PIECE($GET(^DIC(4,$PIECE(^DG(40.8,DIV,0),"^",7),0)),"^")_"^"_SITE
+24 QUIT SITE
+25 ;
ALL(DATE) ; -returns all possible station numbers
+1 ; -input date, if date is undefined, then date will be today
+2 ; - output VASITE= 1 or -1 if stations exist
+3 ; VASITE(station number)=station number
+4 ;
+5 NEW PRIM,DIV
+6 IF '$DATA(DATE)
SET DATE=DT
+7 SET VASITE=-1
+8 ;S DIV=0 F S DIV=$O(^VA(389.9,"C",DIV)) Q:'DIV S PRIM=$G(^VA(389.9,+$O(^(+$O(^VA(389.9,"AIVDT",DIV,$$IVDATE(DATE))),0)),0)) S:'$P(PRIM,"^",6)&($P(PRIM,"^",4)?3N) VASITE($P(PRIM,"^",4))=$P(PRIM,"^",4),VASITE=1 ;IHS/ANMC/LJF 9/21/2000
+9 ;IHS/ANMC/LJF 9/21/2000
SET DIV=0
FOR
SET DIV=$ORDER(^VA(389.9,"C",DIV))
IF 'DIV
QUIT
SET PRIM=$GET(^VA(389.9,+$ORDER(^(+$ORDER(^VA(389.9,"AIVDT",DIV,$$IVDATE(DATE))),0)),0))
IF '$PIECE(PRIM,"^",6)&($PIECE(PRIM,"^",4)?6N)
SET VASITE($PIECE(PRIM,"^",4))=$PIECE(PRIM,"^",4)
SET VASITE=1
+10 QUIT VASITE
+11 ;
IVDATE(DATE) ; -- inverse date reference start
+1 QUIT -(DATE+.000001)
+2 ;
CHK ; -input transform for IS PRIMARY STATION? field
+1 ; -only 1 primary station number allowed per effective date
+2 ;
+3 IF '$PIECE(^VA(389.9,DA,0),"^",2)
WRITE !,"Effective Date must be entered first"
KILL X
GOTO CHKQ
+4 IF '$PIECE(^VA(389.9,DA,0),"^",3)
WRITE !,"Medical Center Division must be entered first.",!
KILL X
GOTO CHKQ
+5 IF $DATA(^VA(389.9,"AIVDT1",1,-X))
WRITE !,"Another entry Is Primary Division for this date.",!
KILL X
GOTO CHKQ
+6 IF 1
CHKQ IF 0
QUIT
+1 ;
YN ; -input transform for is primary facility
+1 IF '$PIECE(^VA(389.9,DA,0),"^",2)
WRITE !,"Effective date must be entered first!"
KILL X
QUIT
+2 IF '$PIECE(^VA(389.9,DA,0),"^",3)
WRITE !,"Medical Center Division must be entered first!"
KILL X
QUIT
+3 IF $DATA(^VA(389.9,"AIVDT1",1,-$PIECE(^VA(389.9,DA,0),"^",2)))
WRITE !,"Only one division can be primary division for an effective date!"
KILL X
QUIT
+4 SET X=$EXTRACT(X)
SET X=$SELECT(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2)
IF X'=2
WRITE " (",$SELECT(X:"YES",1:"NO"),")"
QUIT
+5 WRITE !?4,"NOT A VALID CHOICE!",*7
KILL X
QUIT
+6 ;
PRIM(DATE) ; -returns medical center division of primary medical center division
+1 ; - input date, if date is null then date will be today
+2 ;
+3 ;Q +$O(^DG(40.8,"C",DUZ(2),0)) ;IHS/ANMC/LJF 7/31/2001
+4 ;cmi/maw 3/9/2010 PATCH 1012 for station number
QUIT +$ORDER(^DG(40.8,"AD",DUZ(2),0))
+5 NEW PRIM
+6 IF '$DATA(DATE)
SET DATE=DT
SET DATE=DATE+.24
+7 SET PRIM=$GET(^VA(389.9,+$ORDER(^(+$ORDER(^VA(389.9,"AIVDT1",1,$$IVDATE(DATE))),0)),0))
+8 QUIT $SELECT($PIECE(PRIM,"^",4)?3N:$PIECE(PRIM,"^",3),1:-1)
+9 ;
NAME(DATE) ; -returns the new name of medical centers that have integrated
+1 ;
+2 ; -input date, if date is null then date will be today
+3 IF '$DATA(DATE)
SET DATE=DT
SET DATE=DATE+.24
+4 QUIT $GET(^VA(389.9,+$ORDER(^(+$ORDER(^VA(389.9,"AIVDT1",1,$$IVDATE(DATE))),0)),"INTEG"))
