DVBAB84 ;ALB/DK - CAPRI REMOTE NEW PERSON FILE ;09/28/09
 ;;2.7;AMIE;**90,137,140,143**;Apr 10, 1995;Build 4
 ;
START(MSG) ;RPC DVBAB NEW PERSON FILE
 
^TMP("DVBAB200",$J)
 
DATA,VAR,VAR1,DVBDIV,DVBDIVN,DVBRPT,CNT
 
DATA="",CNT=0,MSG=$NA(^TMP("DVBAB200",$J))
 
F  S DATA=$O(^VA(200,"B",DATA)) Q:DATA=""  D
 
VAR=""
 
F  S VAR=$O(^VA(200,"B",DATA,VAR)) Q:VAR=""  D
 
. . GETS^DIQ(200,VAR_",",".01","E","DVBRPT")
 . . 
I $P($G(^VA(200,VAR,2,0)),"^",3)'="" D  Q
 
. . . VAR1=""
 
. . . F  S VAR1=$O(^VA(200,VAR,2,"B",VAR1)) Q:VAR1=""  D
 
. . . . DVBDIV=$$GET1^DIQ(200.02,VAR1_","_VAR_",",.01,"I")
 . . . . 
DVBDIVN=$$GET1^DIQ(200.02,VAR1_","_VAR_",",.01,"E")
 . . . . 
^TMP("DVBAB200",$J,CNT)=VAR_"^"_DVBRPT(200,VAR_",",.01,"E")_"^"_DVBDIV_"^"_DVBDIVN_$C(13)
 . . . . 
CNT=CNT+1
 . . 
^TMP("DVBAB200",$J,CNT)=VAR_"^"_DVBRPT(200,VAR_",",.01,"E")_"^"_"^"_$C(13)
 . . 
CNT=CNT+1
 
Q
DUZ2(Y,NUM) ;RPC DVBAB SET DUZ2
 
X,NUM=$G(NUM),Y=1,X="0^STATION NUMBER "
 
NUM="" Y=X_"IS REQUIRED"
 
'$D(^DIC(4,"D",NUM))&Y=X_"DOES NOT EXIST"
 
Q:'Y  Y=$O(^DIC(4,"D",NUM,"")),Z=""
 
S:Y]"" Z=$G(^DIC(4,Y,0))
 
Y=""!(Z=""Y=X_"HAS A BAD X-REF" Q
 S 
DUZ(2)=Y,Y=Y_U_$P(Z,U)
 
Q
DUP(Y,NAM,DOB,SSN) ;RPC DVBAB FIND DUPS
 
E,C,N,D,S,A,B,B=" - Must be ",M=B_"at least 1 argument"
 
NAM=$$N0($G(NAM)),DOB=$P($G(DOB),"."),SSN=$$U($G(SSN))
 
(C,N,D,S)=0,E="-1^Invalid Argument: ",Y=$NA(^TMP("DVBDUP",$J,DUZ)) @Y
 
'$L(NAM_DOB_SSNC=E_"None Passed"_M
 
S:'C&DOB&'$L(NAM_SSNC=E_$P(M," ",3,8)_" passed with DOB"
 
S:'C N=$$VN(NAMC=E_"NAM"_B_"LAST,FIRST or IEN"
 
S:'C D=$$VD(DOBC=E_"DOB"_B_"FileMan format"
 
S:'C S=$$VS(SSNS>0 C=E_"SSN"_B_"9 digits, 1U4N format, or P (for pseudo-SSN)"
 
@Y@(0)=Q
 S
:S<0 SSN=$$S(NAM,DOB)
 
DN(.N,NAM),DD(.D,DOB,NAM,SSN),DS(.S,SSN,NAM,DOB),WT(Y,.A,.N,.D,.S)
 
Q
DN(A,N) N=""!A=0 Q  ;Dup Name checks
 
K,A=0,M=$$N2(N),K=$$N1(M)_"zzzzzzzzzz"
 
F  S K=$O(^DPT("B",K)) Q:$$N2(K)'=M  D:$$M("N",K,N,,,5) D0(.A,"B",K)
 
Q
DD(A,D,N,S) A!'A=0 Q  ;Dup DOB checks
 
K,M,A=0,M=$E(D,1,5),K=M-1_99
 
F  S K=$O(^DPT("ADOB",K)) Q:$E(K,1,5)'=M  D
 
.F=0 N]"",$$M("DN",K,N,D,,7) F=1
 .
'F,S]"",$$M("DS",K,,D,S,7) F=1
 .
D:D0(.A,"ADOB",K)
 
Q
DS(A,S,N,D) F,K,M,X,R,A!'A=0 Q  ;Dup SSN checks
 
A=0,P=$L(S),R=P-4,M=$E(S,1,R),K=M-1_9999,X=$S(P=5:"BS5",1:"SSN")
 
F  S K=$O(^DPT(X,K)) Q:$E(K,1,R)'=M  D
 
.F=$$M("S",K,,,S,PD0(.A,X,KQ
 
.Q:N=""&'D  Q:'$$FF(S,K)
 .
D,$$MD(K,D,1) D0(.A,X,K,3,DQ
 
.N]"",$$MN(K,N,1) D0(.A,X,K,1,N)
 
Q
D0(A,X,Y,P,V) I,C,I="",C="N D     S",P=$G(P),V=$G(V)
 
F  S I=$O(^DPT(X,Y,I)) Q:'I  D
 
.Z=$G(^DPT(I,0)) Q:Z=""
 
.P,'$$M($E(C,P),$P(Z,U,P),V,V,V,5) Q
 
.A=A+1,A(I)=Z
 
Q
VN(X) Q:X="" 0  X'?2.U1","1.U  ;Validate Name
VD(X) Q:X="" 0  Q:X'?71  M,M=$E(X,4,5),D=$E(X,6,7)  ;Validate DOB
 
Q:M<1!(M>12)!(D<0) 1  (D>$$D(M,$E(X,1,3)))
VS(X) Q:X="" 0  Q:$E(X,$L(X))="P" -1  L=$L(X)  ;Validate SSN
 
Q:L=5&(X'?1A4N)!(L=9&(X'?9N))!(L<5)!(L>9) 1
 
Q:$E(X,1,5)="00000" 0  ;Test Patient
 
Q $E(X,1)=9!($E(X,1,3)="000")  ;Can't begin with 9 or 000
MN(X,N,F) F=$G(F)_U_($$N2(X,2)=$$N2(N,2)) Q:'$P(F,U,2)  Q $$N2(X)=$$N2(N)  ;Match Name
MD(X,D,F) F=$G(F)_U_($E(X,4,5)=$E(D,4,5)) Q:'$P(F,U,2)  Q $E(X,1,3)=$E(D,1,3)  ;Match DOB
MS(X,S) I,K=0,X=$$L4(X),S=$$L4(S)  ;Match SSN
 
I=1:1:4 K=$E(X,I)=$E(S,I)+K
 
Q:K>1 1  ;2 nums, same spot
 
Q $$S4(X)=$$S4(S)  ;ALL 4 nums, any spot
M(Y,X,N,D,S,L) A,B,C,(A,B,C)=0,Z=$L(X),L=+$G(LQ:Z<0
 
S:Y["N" A=$$MN(X,NS:Y["D" B=$$MD(X,DS:Y["S" C=$$MS(X,S)
 
Q:Y="N" A  Q:Y="D" B  Q:Y="S" C  Q:Y'["N" B&C
 
Q:Y'["D" A&C  Q:Y'["S" A&B  A&B&C
WT(Y,A,N,D,S) C=$$W0(.A,.N,.D,.S),@Y@(0)=Q:'C  ;Weights
 
I,J,K,(C,I,J,K,L)=""
 
F  S I=$O(A(I)) Q:'I  F  S J=$O(A(I,J)) Q:'J  D
 
.K=K+1,K(-J,$P(A(I,J),U),K)=I_U_A(I,J)
 
F  S I=$O(K(I)) Q:'I  F  S J=$O(K(I,J)) Q:J=""  D
 
.F  S L=$O(K(I,J,L)) Q:'L  D
 
..;If SSN or DOB should not be displayed in the Patient File Matches 
 
..;list in CAPRI replace DOB and SSN with *SENSITIVE* in DOB and SSN 
 
..;fields in RPC results.
 
..DVBADOB,DVBASSN,DVBADFN
 
..;1st piece in K array is DFN followed by 0th node of DPT record.
 
..;DOB found in 3rd piece of 0th node and 4th piece K array
 
..DVBADFN=+$P($G(K(I,J,L)),"^")
 ..
DVBADOB=$$DOB^DPTLK1(DVBADFN,2)
 ..
DVBADOB="*SENSITIVE*" S $P(K(I,J,L),"^",4)=DVBADOB
 
..;1st piece in K array is DFN followed by 0th node of DPT( record.  
 
..;SSN found in 9th piece of the 0th node and 10 piece in K array.
 
..DVBASSN=$$SSN^DPTLK1(DVBADFN)
 ..
DVBASSN="*SENSITIVE*" S $P(K(I,J,L),"^",10)=DVBASSN
 
..C=C+1
 ..
@Y@(C)=K(I,J,L)
 
Q
W0(A,N,D,S) Q:N&D&$$W3(.A,.N,.D,.S)  Q:N&S&'$$W2(.A,.N,.S)
 
Q:D&S&'$$W2(.A,.D,.S)  Q:N&D&'$$W2(.A,.N,.D)
 
Q:S&'N&'$$W1(.A,.S)  Q:N&'D&'$$W1(.A,.N)  ;Q:D&'N&'S $$W1(.A,.D)
 
0
W1(A,X) I,(I,C)=0 ;Weighting 1
 
F  S I=$O(X(I)) Q:'I  C=C+1,A(I,1)=X(I)
 
C
W2(A,X,Y) I,(I,C)=0 ;Weighting 2
 
F  S I=$O(X(I)) Q:'I  C=C+1 D
 
.I $D(Y(I)) A(I,2)=Y(I)
 .
E  S A(I,1)=X(I)
 
F  S I=$O(Y(I)) Q:'I  S:'$D(X(I)) C=C+1,A(I,1)=Y(I)
 
C
W3(A,X,Y,Z) I,(I,C)=0 ;Weighting 3
 
F  S I=$O(X(I)) Q:'I  C=C+1 D
 
.I $D(Y(I)) D  Q
 
..I $D(Z(I)) A(I,3)=Z(I)
 ..
E  S A(I,2)=Y(I)
 .
I $D(Z(I)) A(I,2)=Z(I)
 .
E  S A(I,1)=X(I)
 
C+$$W2(.A,.Y,.Z)
N0(X) Q:X="" ""  X?.1"`"1.N S:X["`" X=$P(X,"`",2) X=$P($G(^DPT(X,0)),U)
 
Q $$U($$P(X,", "))
N1(X) Q $E(X,1,$L(X)-1)_$C($A($E(X,$L(X)))-1)
N2(X,Y) Q $E($$P($P(X,",",$G(Y,1)),2),1,2)
U(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
L4(X) L=$L(XS:$E(X,L)="P" L=L-1,X=$E(X,1,LQ $E(X,L-3,L)
D(M,Y) Q:M=2 28+$$L(Y+1700)  31-((M<7&'(M#2))!(M>7&(M#2)))
L(Y) Y#100!('(Y#400)&'(Y#4))
C(X) X=$A($E(X,1))-65\3+1 Q:X<0 0  X
P(X,C,L) I,Y,Z="",Y=X,C=$G(C,U),L=$G(L,$L(Y))
 
I=1:1:$L(YQ:$L(Z)=L  X=$E(Y,IS:X?1U!(C[XZ=Z_X
 
Z
S(N,D) L1,L2,L3 S:$G(D)="" D=2000000 ;PSEU^DGRPDD1
 
L3=$$C(N),L1=$$C($P(N," ",2)),L2=$$C($P(N,",",2))
 
L2_L1_L3_$E(D,4,7)_$E(D,2,3)_"P"
A(X) Q $S(X<0:X*-1,1:X)
FF(X,Y) I,X=$$L4(X),Y=$$L4(Y),K=0
 
I=1:1:4 S:$$A($E(X,I)-$E(Y,I))<2 K=K+1
 
K>2
S4(X) I,J,K,L,L=$L(X)
 
I=2:1:J=I,K=$E(X,ID
 
.F  Q:J=1  M=$E(X,J-1)  Q:M'>K  S $E(X,J)=M,J=J-1
 .
S $E(X,J)=K
 
X