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
K ^TMP("DVBAB200",$J)
N DATA,VAR,VAR1,DVBDIV,DVBDIVN,DVBRPT,CNT
S DATA="",CNT=0,MSG=$NA(^TMP("DVBAB200",$J))
F S DATA=$O(^VA(200,"B",DATA)) Q:DATA="" D
. S VAR=""
. F S VAR=$O(^VA(200,"B",DATA,VAR)) Q:VAR="" D
. . D GETS^DIQ(200,VAR_",",".01","E","DVBRPT")
. . I $P($G(^VA(200,VAR,2,0)),"^",3)'="" D Q
. . . S VAR1=""
. . . F S VAR1=$O(^VA(200,VAR,2,"B",VAR1)) Q:VAR1="" D
. . . . S DVBDIV=$$GET1^DIQ(200.02,VAR1_","_VAR_",",.01,"I")
. . . . S DVBDIVN=$$GET1^DIQ(200.02,VAR1_","_VAR_",",.01,"E")
. . . . S ^TMP("DVBAB200",$J,CNT)=VAR_"^"_DVBRPT(200,VAR_",",.01,"E")_"^"_DVBDIV_"^"_DVBDIVN_$C(13)
. . . . S CNT=CNT+1
. . S ^TMP("DVBAB200",$J,CNT)=VAR_"^"_DVBRPT(200,VAR_",",.01,"E")_"^"_"^"_$C(13)
. . S CNT=CNT+1
Q
DUZ2(Y,NUM) ;RPC DVBAB SET DUZ2
N X,Z S NUM=$G(NUM),Y=1,X="0^STATION NUMBER "
I NUM="" S Y=X_"IS REQUIRED"
I '$D(^DIC(4,"D",NUM))&Y S Y=X_"DOES NOT EXIST"
Q:'Y S Y=$O(^DIC(4,"D",NUM,"")),Z=""
S:Y]"" Z=$G(^DIC(4,Y,0))
I Y=""!(Z="") S 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
N E,C,N,D,S,A,B,M S B=" - Must be ",M=B_"at least 1 argument"
S NAM=$$N0($G(NAM)),DOB=$P($G(DOB),"."),SSN=$$U($G(SSN))
S (C,N,D,S)=0,E="-1^Invalid Argument: ",Y=$NA(^TMP("DVBDUP",$J,DUZ)) K @Y
I '$L(NAM_DOB_SSN) S C=E_"None Passed"_M
S:'C&DOB&'$L(NAM_SSN) C=E_$P(M," ",3,8)_" passed with DOB"
S:'C N=$$VN(NAM) I N S C=E_"NAM"_B_"LAST,FIRST or IEN"
S:'C D=$$VD(DOB) I D S C=E_"DOB"_B_"FileMan format"
S:'C S=$$VS(SSN) I S>0 S C=E_"SSN"_B_"9 digits, 1U4N format, or P (for pseudo-SSN)"
I C S @Y@(0)=C Q
S:S<0 SSN=$$S(NAM,DOB)
D DN(.N,NAM),DD(.D,DOB,NAM,SSN),DS(.S,SSN,NAM,DOB),WT(Y,.A,.N,.D,.S)
Q
DN(A,N) I N=""!A S A=0 Q ;Dup Name checks
N K,M S 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) I A!'D S A=0 Q ;Dup DOB checks
N K,M,F S 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
.S F=0 I N]"",$$M("DN",K,N,D,,7) S F=1
.I 'F,S]"",$$M("DS",K,,D,S,7) S F=1
.D:F D0(.A,"ADOB",K)
Q
DS(A,S,N,D) N F,K,M,X,R,P I A!'S S A=0 Q ;Dup SSN checks
S 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
.S F=$$M("S",K,,,S,P) I F D D0(.A,X,K) Q
.Q:N=""&'D Q:'$$FF(S,K)
.I D,$$MD(K,D,1) D D0(.A,X,K,3,D) Q
.I N]"",$$MN(K,N,1) D D0(.A,X,K,1,N)
Q
D0(A,X,Y,P,V) N I,C,Z S I="",C="N D S",P=$G(P),V=$G(V)
F S I=$O(^DPT(X,Y,I)) Q:'I D
.S Z=$G(^DPT(I,0)) Q:Z=""
.I P,'$$M($E(C,P),$P(Z,U,P),V,V,V,5) Q
.S A=A+1,A(I)=Z
Q
VN(X) Q:X="" 0 Q X'?2.U1","1.U ;Validate Name
VD(X) Q:X="" 0 Q:X'?7N 1 N M,D S M=$E(X,4,5),D=$E(X,6,7) ;Validate DOB
Q:M<1!(M>12)!(D<0) 1 Q (D>$$D(M,$E(X,1,3)))
VS(X) Q:X="" 0 Q:$E(X,$L(X))="P" -1 N L S 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) S F=$G(F)_U_($$N2(X,2)=$$N2(N,2)) Q:'F $P(F,U,2) Q $$N2(X)=$$N2(N) ;Match Name
MD(X,D,F) S F=$G(F)_U_($E(X,4,5)=$E(D,4,5)) Q:'F $P(F,U,2) Q $E(X,1,3)=$E(D,1,3) ;Match DOB
MS(X,S) N I,K S K=0,X=$$L4(X),S=$$L4(S) ;Match SSN
F I=1:1:4 S 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) N A,B,C,Z S (A,B,C)=0,Z=$L(X),L=+$G(L) Q:Z<L 0
S:Y["N" A=$$MN(X,N) S:Y["D" B=$$MD(X,D) S: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 Q A&B&C
WT(Y,A,N,D,S) N C S C=$$W0(.A,.N,.D,.S),@Y@(0)=C Q:'C ;Weights
N I,J,K,L S (C,I,J,K,L)=""
F S I=$O(A(I)) Q:'I F S J=$O(A(I,J)) Q:'J D
.S 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.
..N 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
..S DVBADFN=+$P($G(K(I,J,L)),"^")
..S DVBADOB=$$DOB^DPTLK1(DVBADFN,2)
..I 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.
..S DVBASSN=$$SSN^DPTLK1(DVBADFN)
..I DVBASSN="*SENSITIVE*" S $P(K(I,J,L),"^",10)=DVBASSN
..S C=C+1
..S @Y@(C)=K(I,J,L)
Q
W0(A,N,D,S) Q:N&D&S $$W3(.A,.N,.D,.S) Q:N&S&'D $$W2(.A,.N,.S)
Q:D&S&'N $$W2(.A,.D,.S) Q:N&D&'S $$W2(.A,.N,.D)
Q:S&'N&'D $$W1(.A,.S) Q:N&'D&'S $$W1(.A,.N) ;Q:D&'N&'S $$W1(.A,.D)
Q 0
W1(A,X) N I,C S (I,C)=0 ;Weighting 1
F S I=$O(X(I)) Q:'I S C=C+1,A(I,1)=X(I)
Q C
W2(A,X,Y) N I,C S (I,C)=0 ;Weighting 2
F S I=$O(X(I)) Q:'I S C=C+1 D
.I $D(Y(I)) S 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)
Q C
W3(A,X,Y,Z) N I,C S (I,C)=0 ;Weighting 3
F S I=$O(X(I)) Q:'I S C=C+1 D
.I $D(Y(I)) D Q
..I $D(Z(I)) S A(I,3)=Z(I)
..E S A(I,2)=Y(I)
.I $D(Z(I)) S A(I,2)=Z(I)
.E S A(I,1)=X(I)
Q C+$$W2(.A,.Y,.Z)
N0(X) Q:X="" "" I X?.1"`"1.N S:X["`" X=$P(X,"`",2) S 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) N L S L=$L(X) S:$E(X,L)="P" L=L-1,X=$E(X,1,L) Q $E(X,L-3,L)
D(M,Y) Q:M=2 28+$$L(Y+1700) Q 31-((M<7&'(M#2))!(M>7&(M#2)))
L(Y) Q Y#100!('(Y#400)&'(Y#4))
C(X) S X=$A($E(X,1))-65\3+1 Q:X<0 0 Q X
P(X,C,L) N I,Y,Z S Z="",Y=X,C=$G(C,U),L=$G(L,$L(Y))
F I=1:1:$L(Y) Q:$L(Z)=L S X=$E(Y,I) S:X?1U!(C[X) Z=Z_X
Q Z
S(N,D) N L1,L2,L3 S:$G(D)="" D=2000000 ;PSEU^DGRPDD1
S L3=$$C(N),L1=$$C($P(N," ",2)),L2=$$C($P(N,",",2))
Q 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) N I,K S X=$$L4(X),Y=$$L4(Y),K=0
F I=1:1:4 S:$$A($E(X,I)-$E(Y,I))<2 K=K+1
Q K>2
S4(X) N I,J,K,L,M S L=$L(X)
F I=2:1:L S J=I,K=$E(X,I) D
.F Q:J=1 S M=$E(X,J-1) Q:M'>K S $E(X,J)=M,J=J-1
.S $E(X,J)=K
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB84 6379 printed Apr 09, 2024@20:55:48 Page 2
DVBAB84 ;ALB/DK - CAPRI REMOTE NEW PERSON FILE ;09/28/09
+1 ;;2.7;AMIE;**90,137,140,143**;Apr 10, 1995;Build 4
+2 ;
START(MSG) ;RPC DVBAB NEW PERSON FILE
+1 KILL ^TMP("DVBAB200",$JOB)
+2 NEW DATA,VAR,VAR1,DVBDIV,DVBDIVN,DVBRPT,CNT
+3 SET DATA=""
SET CNT=0
SET MSG=$NAME(^TMP("DVBAB200",$JOB))
+4 FOR
SET DATA=$ORDER(^VA(200,"B",DATA))
if DATA=""
QUIT
Begin DoDot:1
+5 SET VAR=""
+6 FOR
SET VAR=$ORDER(^VA(200,"B",DATA,VAR))
if VAR=""
QUIT
Begin DoDot:2
+7 DO GETS^DIQ(200,VAR_",",".01","E","DVBRPT")
+8 IF $PIECE($GET(^VA(200,VAR,2,0)),"^",3)'=""
Begin DoDot:3
+9 SET VAR1=""
+10 FOR
SET VAR1=$ORDER(^VA(200,VAR,2,"B",VAR1))
if VAR1=""
QUIT
Begin DoDot:4
+11 SET DVBDIV=$$GET1^DIQ(200.02,VAR1_","_VAR_",",.01,"I")
+12 SET DVBDIVN=$$GET1^DIQ(200.02,VAR1_","_VAR_",",.01,"E")
+13 SET ^TMP("DVBAB200",$JOB,CNT)=VAR_"^"_DVBRPT(200,VAR_",",.01,"E")_"^"_DVBDIV_"^"_DVBDIVN_$CHAR(13)
+14 SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+15 SET ^TMP("DVBAB200",$JOB,CNT)=VAR_"^"_DVBRPT(200,VAR_",",.01,"E")_"^"_"^"_$CHAR(13)
+16 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+17 QUIT
DUZ2(Y,NUM) ;RPC DVBAB SET DUZ2
+1 NEW X,Z
SET NUM=$GET(NUM)
SET Y=1
SET X="0^STATION NUMBER "
+2 IF NUM=""
SET Y=X_"IS REQUIRED"
+3 IF '$DATA(^DIC(4,"D",NUM))&Y
SET Y=X_"DOES NOT EXIST"
+4 if 'Y
QUIT
SET Y=$ORDER(^DIC(4,"D",NUM,""))
SET Z=""
+5 if Y]""
SET Z=$GET(^DIC(4,Y,0))
+6 IF Y=""!(Z="")
SET Y=X_"HAS A BAD X-REF"
QUIT
+7 SET DUZ(2)=Y
SET Y=Y_U_$PIECE(Z,U)
+8 QUIT
DUP(Y,NAM,DOB,SSN) ;RPC DVBAB FIND DUPS
+1 NEW E,C,N,D,S,A,B,M
SET B=" - Must be "
SET M=B_"at least 1 argument"
+2 SET NAM=$$N0($GET(NAM))
SET DOB=$PIECE($GET(DOB),".")
SET SSN=$$U($GET(SSN))
+3 SET (C,N,D,S)=0
SET E="-1^Invalid Argument: "
SET Y=$NAME(^TMP("DVBDUP",$JOB,DUZ))
KILL @Y
+4 IF '$LENGTH(NAM_DOB_SSN)
SET C=E_"None Passed"_M
+5 if 'C&DOB&'$LENGTH(NAM_SSN)
SET C=E_$PIECE(M," ",3,8)_" passed with DOB"
+6 if 'C
SET N=$$VN(NAM)
IF N
SET C=E_"NAM"_B_"LAST,FIRST or IEN"
+7 if 'C
SET D=$$VD(DOB)
IF D
SET C=E_"DOB"_B_"FileMan format"
+8 if 'C
SET S=$$VS(SSN)
IF S>0
SET C=E_"SSN"_B_"9 digits, 1U4N format, or P (for pseudo-SSN)"
+9 IF C
SET @Y@(0)=C
QUIT
+10 if S<0
SET SSN=$$S(NAM,DOB)
+11 DO DN(.N,NAM)
DO DD(.D,DOB,NAM,SSN)
DO DS(.S,SSN,NAM,DOB)
DO WT(Y,.A,.N,.D,.S)
+12 QUIT
DN(A,N) ;Dup Name checks
IF N=""!A
SET A=0
QUIT
+1 NEW K,M
SET A=0
SET M=$$N2(N)
SET K=$$N1(M)_"zzzzzzzzzz"
+2 FOR
SET K=$ORDER(^DPT("B",K))
if $$N2(K)'=M
QUIT
if $$M("N",K,N,,,5)
DO D0(.A,"B",K)
+3 QUIT
DD(A,D,N,S) ;Dup DOB checks
IF A!'D
SET A=0
QUIT
+1 NEW K,M,F
SET A=0
SET M=$EXTRACT(D,1,5)
SET K=M-1_99
+2 FOR
SET K=$ORDER(^DPT("ADOB",K))
if $EXTRACT(K,1,5)'=M
QUIT
Begin DoDot:1
+3 SET F=0
IF N]""
IF $$M("DN",K,N,D,,7)
SET F=1
+4 IF 'F
IF S]""
IF $$M("DS",K,,D,S,7)
SET F=1
+5 if F
DO D0(.A,"ADOB",K)
End DoDot:1
+6 QUIT
DS(A,S,N,D) ;Dup SSN checks
NEW F,K,M,X,R,P
IF A!'S
SET A=0
QUIT
+1 SET A=0
SET P=$LENGTH(S)
SET R=P-4
SET M=$EXTRACT(S,1,R)
SET K=M-1_9999
SET X=$SELECT(P=5:"BS5",1:"SSN")
+2 FOR
SET K=$ORDER(^DPT(X,K))
if $EXTRACT(K,1,R)'=M
QUIT
Begin DoDot:1
+3 SET F=$$M("S",K,,,S,P)
IF F
DO D0(.A,X,K)
QUIT
+4 if N=""&'D
QUIT
if '$$FF(S,K)
QUIT
+5 IF D
IF $$MD(K,D,1)
DO D0(.A,X,K,3,D)
QUIT
+6 IF N]""
IF $$MN(K,N,1)
DO D0(.A,X,K,1,N)
End DoDot:1
+7 QUIT
D0(A,X,Y,P,V) NEW I,C,Z
SET I=""
SET C="N D S"
SET P=$GET(P)
SET V=$GET(V)
+1 FOR
SET I=$ORDER(^DPT(X,Y,I))
if 'I
QUIT
Begin DoDot:1
+2 SET Z=$GET(^DPT(I,0))
if Z=""
QUIT
+3 IF P
IF '$$M($EXTRACT(C,P),$PIECE(Z,U,P),V,V,V,5)
QUIT
+4 SET A=A+1
SET A(I)=Z
End DoDot:1
+5 QUIT
VN(X) ;Validate Name
if X=""
QUIT 0
QUIT X'?2.U1","1.U
VD(X) ;Validate DOB
if X=""
QUIT 0
if X'?7N
QUIT 1
NEW M,D
SET M=$EXTRACT(X,4,5)
SET D=$EXTRACT(X,6,7)
+1 if M<1!(M>12)!(D<0)
QUIT 1
QUIT (D>$$D(M,$EXTRACT(X,1,3)))
VS(X) ;Validate SSN
if X=""
QUIT 0
if $EXTRACT(X,$LENGTH(X))="P"
QUIT -1
NEW L
SET L=$LENGTH(X)
+1 if L=5&(X'?1A4N)!(L=9&(X'?9N))!(L<5)!(L>9)
QUIT 1
+2 ;Test Patient
if $EXTRACT(X,1,5)="00000"
QUIT 0
+3 ;Can't begin with 9 or 000
QUIT $EXTRACT(X,1)=9!($EXTRACT(X,1,3)="000")
MN(X,N,F) ;Match Name
SET F=$GET(F)_U_($$N2(X,2)=$$N2(N,2))
if 'F
QUIT $PIECE(F,U,2)
QUIT $$N2(X)=$$N2(N)
MD(X,D,F) ;Match DOB
SET F=$GET(F)_U_($EXTRACT(X,4,5)=$EXTRACT(D,4,5))
if 'F
QUIT $PIECE(F,U,2)
QUIT $EXTRACT(X,1,3)=$EXTRACT(D,1,3)
MS(X,S) ;Match SSN
NEW I,K
SET K=0
SET X=$$L4(X)
SET S=$$L4(S)
+1 FOR I=1:1:4
SET K=$EXTRACT(X,I)=$EXTRACT(S,I)+K
+2 ;2 nums, same spot
if K>1
QUIT 1
+3 ;ALL 4 nums, any spot
QUIT $$S4(X)=$$S4(S)
M(Y,X,N,D,S,L) NEW A,B,C,Z
SET (A,B,C)=0
SET Z=$LENGTH(X)
SET L=+$GET(L)
if Z<L
QUIT 0
+1 if Y["N"
SET A=$$MN(X,N)
if Y["D"
SET B=$$MD(X,D)
if Y["S"
SET C=$$MS(X,S)
+2 if Y="N"
QUIT A
if Y="D"
QUIT B
if Y="S"
QUIT C
if Y'["N"
QUIT B&C
+3 if Y'["D"
QUIT A&C
if Y'["S"
QUIT A&B
QUIT A&B&C
WT(Y,A,N,D,S) ;Weights
NEW C
SET C=$$W0(.A,.N,.D,.S)
SET @Y@(0)=C
if 'C
QUIT
+1 NEW I,J,K,L
SET (C,I,J,K,L)=""
+2 FOR
SET I=$ORDER(A(I))
if 'I
QUIT
FOR
SET J=$ORDER(A(I,J))
if 'J
QUIT
Begin DoDot:1
+3 SET K=K+1
SET K(-J,$PIECE(A(I,J),U),K)=I_U_A(I,J)
End DoDot:1
+4 FOR
SET I=$ORDER(K(I))
if 'I
QUIT
FOR
SET J=$ORDER(K(I,J))
if J=""
QUIT
Begin DoDot:1
+5 FOR
SET L=$ORDER(K(I,J,L))
if 'L
QUIT
Begin DoDot:2
+6 ;If SSN or DOB should not be displayed in the Patient File Matches
+7 ;list in CAPRI replace DOB and SSN with *SENSITIVE* in DOB and SSN
+8 ;fields in RPC results.
+9 NEW DVBADOB,DVBASSN,DVBADFN
+10 ;1st piece in K array is DFN followed by 0th node of DPT record.
+11 ;DOB found in 3rd piece of 0th node and 4th piece K array
+12 SET DVBADFN=+$PIECE($GET(K(I,J,L)),"^")
+13 SET DVBADOB=$$DOB^DPTLK1(DVBADFN,2)
+14 IF DVBADOB="*SENSITIVE*"
SET $PIECE(K(I,J,L),"^",4)=DVBADOB
+15 ;1st piece in K array is DFN followed by 0th node of DPT( record.
+16 ;SSN found in 9th piece of the 0th node and 10 piece in K array.
+17 SET DVBASSN=$$SSN^DPTLK1(DVBADFN)
+18 IF DVBASSN="*SENSITIVE*"
SET $PIECE(K(I,J,L),"^",10)=DVBASSN
+19 SET C=C+1
+20 SET @Y@(C)=K(I,J,L)
End DoDot:2
End DoDot:1
+21 QUIT
W0(A,N,D,S) if N&D&S
QUIT $$W3(.A,.N,.D,.S)
if N&S&'D
QUIT $$W2(.A,.N,.S)
+1 if D&S&'N
QUIT $$W2(.A,.D,.S)
if N&D&'S
QUIT $$W2(.A,.N,.D)
+2 ;Q:D&'N&'S $$W1(.A,.D)
if S&'N&'D
QUIT $$W1(.A,.S)
if N&'D&'S
QUIT $$W1(.A,.N)
+3 QUIT 0
W1(A,X) ;Weighting 1
NEW I,C
SET (I,C)=0
+1 FOR
SET I=$ORDER(X(I))
if 'I
QUIT
SET C=C+1
SET A(I,1)=X(I)
+2 QUIT C
W2(A,X,Y) ;Weighting 2
NEW I,C
SET (I,C)=0
+1 FOR
SET I=$ORDER(X(I))
if 'I
QUIT
SET C=C+1
Begin DoDot:1
+2 IF $DATA(Y(I))
SET A(I,2)=Y(I)
+3 IF '$TEST
SET A(I,1)=X(I)
End DoDot:1
+4 FOR
SET I=$ORDER(Y(I))
if 'I
QUIT
if '$DATA(X(I))
SET C=C+1
SET A(I,1)=Y(I)
+5 QUIT C
W3(A,X,Y,Z) ;Weighting 3
NEW I,C
SET (I,C)=0
+1 FOR
SET I=$ORDER(X(I))
if 'I
QUIT
SET C=C+1
Begin DoDot:1
+2 IF $DATA(Y(I))
Begin DoDot:2
+3 IF $DATA(Z(I))
SET A(I,3)=Z(I)
+4 IF '$TEST
SET A(I,2)=Y(I)
End DoDot:2
QUIT
+5 IF $DATA(Z(I))
SET A(I,2)=Z(I)
+6 IF '$TEST
SET A(I,1)=X(I)
End DoDot:1
+7 QUIT C+$$W2(.A,.Y,.Z)
N0(X) if X=""
QUIT ""
IF X?.1"`"1.N
if X["`"
SET X=$PIECE(X,"`",2)
SET X=$PIECE($GET(^DPT(X,0)),U)
+1 QUIT $$U($$P(X,", "))
N1(X) QUIT $EXTRACT(X,1,$LENGTH(X)-1)_$CHAR($ASCII($EXTRACT(X,$LENGTH(X)))-1)
N2(X,Y) QUIT $EXTRACT($$P($PIECE(X,",",$GET(Y,1)),2),1,2)
U(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
L4(X) NEW L
SET L=$LENGTH(X)
if $EXTRACT(X,L)="P"
SET L=L-1
SET X=$EXTRACT(X,1,L)
QUIT $EXTRACT(X,L-3,L)
D(M,Y) if M=2
QUIT 28+$$L(Y+1700)
QUIT 31-((M<7&'(M#2))!(M>7&(M#2)))
L(Y) QUIT Y#100!('(Y#400)&'(Y#4))
C(X) SET X=$ASCII($EXTRACT(X,1))-65\3+1
if X<0
QUIT 0
QUIT X
P(X,C,L) NEW I,Y,Z
SET Z=""
SET Y=X
SET C=$GET(C,U)
SET L=$GET(L,$LENGTH(Y))
+1 FOR I=1:1:$LENGTH(Y)
if $LENGTH(Z)=L
QUIT
SET X=$EXTRACT(Y,I)
if X?1U!(C[X)
SET Z=Z_X
+2 QUIT Z
S(N,D) ;PSEU^DGRPDD1
NEW L1,L2,L3
if $GET(D)=""
SET D=2000000
+1 SET L3=$$C(N)
SET L1=$$C($PIECE(N," ",2))
SET L2=$$C($PIECE(N,",",2))
+2 QUIT L2_L1_L3_$EXTRACT(D,4,7)_$EXTRACT(D,2,3)_"P"
A(X) QUIT $SELECT(X<0:X*-1,1:X)
FF(X,Y) NEW I,K
SET X=$$L4(X)
SET Y=$$L4(Y)
SET K=0
+1 FOR I=1:1:4
if $$A($EXTRACT(X,I)-$EXTRACT(Y,I))<2
SET K=K+1
+2 QUIT K>2
S4(X) NEW I,J,K,L,M
SET L=$LENGTH(X)
+1 FOR I=2:1:L
SET J=I
SET K=$EXTRACT(X,I)
Begin DoDot:1
+2 FOR
if J=1
QUIT
SET M=$EXTRACT(X,J-1)
if M'>K
QUIT
SET $EXTRACT(X,J)=M
SET J=J-1
+3 SET $EXTRACT(X,J)=K
End DoDot:1
+4 QUIT X
