- LRBLSSN ; IHS/DIR/FJE - SSN SYNTAX CHECKER/EDIT 11/12/88 15:30 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ;INPUT SCREEN FOR 65.5,.13 'G' X-REF
- ;IHS/ANMC/CLS 11/1/95 blood donor file
- 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
- LRBLSSN ; IHS/DIR/FJE - SSN SYNTAX CHECKER/EDIT 11/12/88 15:30 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 ;INPUT SCREEN FOR 65.5,.13 'G' X-REF
- +5 ;IHS/ANMC/CLS 11/1/95 blood donor file
- +6 KILL A
- IF X'="P"&($LENGTH(X)<9)
- KILL X
- GOTO END
- +7 SET A=X
- DO STRIP
- IF A'="P"&($LENGTH(A)<9)
- KILL X
- GOTO END
- +8 IF A="P"
- DO PSUE
- DO PCHK
- SET X=L_"P"
- GOTO END
- +9 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
- +10 IF $LENGTH(A)>9
- IF $EXTRACT(A,10)'="P"
- KILL X
- GOTO END
- +11 IF A'?9N
- KILL X
- GOTO END
- +12 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
