- 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 Jan 18, 2025@02:41:53 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