LRBLSSN ;DALISC/FHS/DVR/AVAMC/REG - SSN SYNTAX CHECKER/EDIT ; 11/12/88 15:30 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;INPUT SCREEN FOR 65.5,.13 'G' X-REF
K A I X'="P"&($L(X)<9) K X G END
S A=X D STRIP I A'="P"&($L(A)<9) K X G END
I A="P" D PSUE,PCHK S X=L_"P" G END
I $E(A,10)="P" D PSUE S L=L_"P" S:A=L B=A D:'$D(B) PV D DUP G END
I $L(A)>9,$E(A,10)'="P" K X G END
I A'?9N K X G END
G:$D(^LRE("G",A))&('$D(^LRE("G",A,DA))) NO S X=A
END K %,A,B,C,L,N,Z Q
CON S Z=$A(Z)-65\3+1 S:Z<0 Z=0 Q
PCHK ;CHECK FOR DUPLICATE 'P' NUMBERS
Q:$D(^LRE("G",L_"P",DA))
Q:'$D(^LRE("G",L_"P")) F A=0:0 S L=L+1 Q:$D(^LRE("G",L_"P",DA))!'($D(^LRE("G",L_"P")))
Q
STRIP I A'?.AN F %=1:1:$L(A) I $E(A,%)?1P S A=$E(A,0,%-1)_$E(A,%+1,99),%=%-1
Q
PSUE S L=^LRE(DA,0),C=$P(L,"^",3),N=$P(L,"^"),L(1)=$E($P(N," ",2)),L(3)=$E(N),L(2)=$E($P(N,",",2))
S Z=L(1) D CON S L(1)=Z,Z=L(2) D CON S L(2)=Z,Z=L(3) D CON S L(3)=Z,L=L(2)_L(1)_L(3)_$E(C,4,7)_$E(C,2,3)
Q
PV I '$D(^LRE("G",A,DA)) W !!?10,$C(7),"Not a proper Pseudo SSN. Enter 9 numbers followed by 'P'",!?15,"or you may enter a 'P'." K X Q
Q
NO S N(1)=+$O(^LRE("G",A,0)),N=$S($D(^LRE(N(1),0)):$P(^(0),U),1:"Error in Data Base ") W !?10,"This SSN is assigned to ",N,!?15,"Donor #:",N(1),! K X G END
DUP I $D(^LRE("G",A))&'($D(^LRE("G",A,DA))) S N(1)=+$O(^LRE("G",A,0)),N=$P(^LRE(N(1),0),U) W !!?10,"Duplicate Pseudo Number -- ALREADY AS ASSIGNED TO ",N,!?15,"Donor # :",N(1),! K X Q
S:$D(X) X=A Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLSSN 1556 printed Oct 16, 2024@18:13:01 Page 2
LRBLSSN ;DALISC/FHS/DVR/AVAMC/REG - SSN SYNTAX CHECKER/EDIT ; 11/12/88 15:30 ;
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;INPUT SCREEN FOR 65.5,.13 'G' X-REF
+4 KILL A
IF X'="P"&($LENGTH(X)<9)
KILL X
GOTO END
+5 SET A=X
DO STRIP
IF A'="P"&($LENGTH(A)<9)
KILL X
GOTO END
+6 IF A="P"
DO PSUE
DO PCHK
SET X=L_"P"
GOTO END
+7 IF $EXTRACT(A,10)="P"
DO PSUE
SET L=L_"P"
if A=L
SET B=A
if '$DATA(B)
DO PV
DO DUP
GOTO END
+8 IF $LENGTH(A)>9
IF $EXTRACT(A,10)'="P"
KILL X
GOTO END
+9 IF A'?9N
KILL X
GOTO END
+10 if $DATA(^LRE("G",A))&('$DATA(^LRE("G",A,DA)))
GOTO NO
SET X=A
END KILL %,A,B,C,L,N,Z
QUIT
CON SET Z=$ASCII(Z)-65\3+1
if Z<0
SET Z=0
QUIT
PCHK ;CHECK FOR DUPLICATE 'P' NUMBERS
+1 if $DATA(^LRE("G",L_"P",DA))
QUIT
+2 if '$DATA(^LRE("G",L_"P"))
QUIT
FOR A=0:0
SET L=L+1
if $DATA(^LRE("G",L_"P",DA))!'($DATA(^LRE("G",L_"P")))
QUIT
+3 QUIT
STRIP IF A'?.AN
FOR %=1:1:$LENGTH(A)
IF $EXTRACT(A,%)?1P
SET A=$EXTRACT(A,0,%-1)_$EXTRACT(A,%+1,99)
SET %=%-1
+1 QUIT
PSUE SET L=^LRE(DA,0)
SET C=$PIECE(L,"^",3)
SET N=$PIECE(L,"^")
SET L(1)=$EXTRACT($PIECE(N," ",2))
SET L(3)=$EXTRACT(N)
SET L(2)=$EXTRACT($PIECE(N,",",2))
+1 SET Z=L(1)
DO CON
SET L(1)=Z
SET Z=L(2)
DO CON
SET L(2)=Z
SET Z=L(3)
DO CON
SET L(3)=Z
SET L=L(2)_L(1)_L(3)_$EXTRACT(C,4,7)_$EXTRACT(C,2,3)
+2 QUIT
PV IF '$DATA(^LRE("G",A,DA))
WRITE !!?10,$CHAR(7),"Not a proper Pseudo SSN. Enter 9 numbers followed by 'P'",!?15,"or you may enter a 'P'."
KILL X
QUIT
+1 QUIT
NO SET N(1)=+$ORDER(^LRE("G",A,0))
SET N=$SELECT($DATA(^LRE(N(1),0)):$PIECE(^(0),U),1:"Error in Data Base ")
WRITE !?10,"This SSN is assigned to ",N,!?15,"Donor #:",N(1),!
KILL X
GOTO END
DUP IF $DATA(^LRE("G",A))&'($DATA(^LRE("G",A,DA)))
SET N(1)=+$ORDER(^LRE("G",A,0))
SET N=$PIECE(^LRE(N(1),0),U)
WRITE !!?10,"Duplicate Pseudo Number -- ALREADY AS ASSIGNED TO ",N,!?15,"Donor # :",N(1),!
KILL X
QUIT
+1 if $DATA(X)
SET X=A
QUIT
