- BPSJPHNM ;BHAM ISC/LJF - HL7 E-Pharm Phone Number Parser ;21-NOV-2003
- ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- ;
- EN(IX1,C,R) ;
- ; Called with Person Index from VA(200
- N N13,RETVAL,RETP,IX,IX2,UC,LC,PHT,SP,C3,PHD,PHDH,FLAG,PHI
- ;
- I '$G(IX1) Q ""
- I $G(IX1) S N13=$G(^VA(200,+IX1,.13))
- I $G(N13)="" Q ""
- I $G(C)="" S C="^"
- I $G(R)="" S R="~"
- ;
- ; Set up lowercase to UPPERCASE translation
- S LC="abcdefghijklmnopqrstuvwxyz"
- S UC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- S SP=" ",C3=C_C_C
- ;
- S PHT(1)=C_"PRN"_C_"PH"_C3 ; home phone
- S PHT(2)=C_"WPN"_C_"PH"_C3 ; work phone
- S PHT(3)=C_"WPN"_C_"PH"_C3 ; 3rd phone
- S PHT(4)=C_"WPN"_C_"PH"_C3 ; 4th phone
- S PHT(5)=C_"WPN"_C_"PH"_C3 ; Commercial phone
- S PHT(6)=C_"WPN"_C_"FX"_C3 ; Fax Number
- S PHT(7)=C_"BPN"_C_"BP"_C3 ; Voice Pager Number
- S PHT(8)=C_"BPN"_C_"BP"_C3 ; Digital Pager Number
- S (PHI(9),PHI(9,1),PHI(9,2),PHI(9,3),PHI(9,4),PHI(9,5))=""
- ;
- K PHD M PHD=PHI S PHD=$G(^VA(200,IX1,.13)) I $TR(PHD,"^ ")="" Q ""
- S PHD(10)=PHD
- ; Trim leading and trailing spaces from each piece
- F IX2=1:1:8 D
- . I $TR($P(PHD,U,IX2),SP)="" S $P(PHD,U,IX2)="" Q
- . S PHDH=$P(PHD,U,IX2)
- . S $P(PHDH,$E($TR(PHDH,SP)))="" ; remove leading spaces
- . S PHDH=$RE(PHDH),$P(PHDH,$E($TR(PHDH,SP)))="",PHDH=$RE(PHDH) ; remove trailing spaces
- . ; remove duplicate work numbers
- . I IX2>1,IX2<6 D Q
- . . I $G(PHD(11,PHDH)) S $P(PHD,U,IX2)=""
- . . E S PHD(11,PHDH)=IX2 S $P(PHD,U,IX2)=PHDH
- . S $P(PHD,U,IX2)=PHDH
- S PHD(10)=PHD
- ;
- ; Massage pagers into pieces 7&8
- F IX2=1:1:6 S PHDH=$P(PHD,U,IX2),FLAG="" I PHDH]"" D
- . I PHDH["BEEPER" D
- . . S FLAG="1"_$P(PHDH,"BEEPER",2,99),PHDH=$P(PHDH,"BEEPER")
- . I PHDH["BEEP" D
- . . S FLAG="1"_$P(PHDH,"BEEP",2,99),PHDH=$P(PHDH,"BEEP")
- . I PHDH["BP#" D
- . . S FLAG="1"_$P(PHDH,"BP#",2,99),PHDH=$P(PHDH,"BP#")
- . I PHDH["BP #" D
- . . S FLAG="1"_$P(PHDH,"BP #",2,99),PHDH=$P(PHDH,"BP #")
- . I PHDH["BP " D
- . . S FLAG="1"_$P(PHDH,"BP ",2,99),PHDH=$P(PHDH,"BP ")
- . I PHDH["BP" D
- . . S FLAG="1"_$P(PHDH,"BP",2,99),PHDH=$P(PHDH,"BP")
- . I FLAG D
- . . S $P(PHD,U,IX2)=PHDH,$E(FLAG)=""
- . . I $P(PHD,U,8)="" S $P(PHD,U,8)=FLAG Q
- . . I $P(PHD,U,7)="" S $P(PHD,U,7)=FLAG Q
- . . S $P(PHD,U,8)=$P(PHD,U,8)_" BP#"_FLAG
- ;
- F IX2=1:1:8 S PHD(IX2)=$P(PHD,U,IX2),PHD(IX2,1)="" I PHD(IX2)]"" D
- . S PHD(IX2,1)=$$RESOLVEP(PHD(IX2))
- . ;Init flag fields then load flags
- . M PHD(IX2,9)=PHD(9)
- ;
- S RETVAL="",RETP=0
- F IX2=1:1:8 D
- . I '$L(PHD(IX2)) Q
- . I '$L(PHD(IX2,1)) S $P(PHD(IX2,1),U,4)=PHD(IX2)
- . S PHD(IX2,1)=PHT(IX2)_PHD(IX2,1)
- . S RETP=RETP+1,$P(RETVAL,R,RETP)=PHD(IX2,1)
- . Q
- Q RETVAL
- ;
- RESOLVEP(PH) ;
- ;
- N WPA,WPN,WPNH,STDN,WPT,IX,STDN,PREFIX
- ;
- S WPT=$TR(PH,LC,UC),PREFIX=0
- S $P(WPN,SP,$L(WPT))=SP,WPA=WPN
- ;
- ; Separate numerics from text
- F IX=1:1:$L(WPT) D
- . I '$E(WPT,IX),$E(WPT,IX)'=0 S $E(WPA,IX)=$E(WPT,IX)
- . E S $E(WPN,IX)=$E(PH,IX)
- ; Quit if no numerics
- I '$L($TR(WPN,SP)) Q ""
- ;
- S WPNH=WPN ; save a copy of the numeric data
- ;
- S $P(WPN,$E($TR(WPN,SP)))="" ; remove leading spaces
- S WPN=$RE(WPN),$P(WPN,$E($TR(WPN,SP)))="",WPN=$RE(WPN) ; remove trailing spaces
- ; Reduce multiple spaces to single spaces
- F IX=$L(WPN):-1:1 I ($E(WPN,IX,IX+1)=(SP_SP)) S $E(WPN,IX)=""
- ;
- ; WPN contains only NUMBERS and SPACES at this point
- ; check if it is preceded by a 1 as in "1 800 345 9933"
- I $E(WPN,1,2)="1 " S $E(WPN,1,2)="",PREFIX=2
- I 'PREFIX,$E(WPN)=1 S $E(WPN)="",PREFIX=1
- ; check if it's a standard 10 digit number
- S STDN=0
- I $L($TR(WPN,SP))=10 S STDN=1 D
- . I $L(WPN)=10 D I STDN=1 Q ; format: 1234567890
- . . S WPN(1)=$E(WPN,1,3),WPN(2)=$E(WPN,4,6),WPN(3)=$E(WPN,7,10)
- . . I PH[WPN(1),PH[WPN(2),PH[WPN(3)
- . . E S STDN=0
- . S STDN=1
- . I $L(WPN,SP)=3 D I STDN Q ; format: 123 456 7890
- . . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2),WPN(3)=$P(WPN,SP,3)
- . . I $L(WPN(1))=3,PH[WPN(1),$L(WPN(2))=3,PH[WPN(2),$L(WPN(3))=4,PH[WPN(3)
- . . E S STDN=0
- . S STDN=1
- . I $L(WPN,SP)=2 D I STDN=1 Q ; Still may be salvageable
- . . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2)
- . . ; is format "123 4567890"? area code & city/phone
- . . I $L(WPN(1))=3 S WPN(3)=$E(WPN(2),4,7),$E(WPN(2),4,7)="" Q
- . . ; is format "123456 7890"? area/city code & phone
- . . I $L(WPN(1))=6 S WPN(3)=WPN(2),WPN(2)=$E(WPN(1),4,6),$E(WPN(1),4,6)="" Q
- . . S STDN=0 ;unsalvageable as standard number
- . S STDN=0 ;unsalvageable as standard number
- ;
- ; Quit if standard format
- I STDN Q WPN(1)_WPN(2)_C_WPN(3)
- ;
- ;Not standard, need to do some work
- ;
- F IX=1:1:$L(WPN,SP) S WPN(IX)=$P(WPN,SP,IX)
- S IX=$L(WPN,SP),WPN(0)=""
- ;
- ; add prefix back in if applicable
- I PREFIX=1,$L(WPN(1))'=10 S WPN(1)="1"_WPN(1)
- ;
- ; 1 string of digits
- I IX=1 D Q:$L(WPN(0)) WPN(0)
- . I $L(WPN(1))<7 S WPN(0)=C_C_WPN(1) Q ;assume it's an extension
- . I $L(WPN(1))=7 S WPN(0)=$E(WPN(1),1,3)_C_$E(WPN(1),4,7) Q ;city code & local number
- ;
- ; 2 strings of digits
- I IX=2 D Q:$L(WPN(0)) WPN(0)
- . ; could be city code & local number
- . I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2) Q
- . ; could be full number plus extension
- . I $L(WPN(1))=10 S WPN(0)=$E(WPN(1),1,6)_C_$E(WPN(1),7,10)_C_WPN(2)
- ;
- ; 3 strings could include extension
- I IX=3 D Q:$L(WPN(0)) WPN(0)
- . ; "301 7933124 123"
- . I $L(WPN(1))=3,$L(WPN(2))=7 S WPN(0)=WPN(1)_$E(WPN(2),1,3)_C_$E(WPN(2),4,7)_C_WPN(3) Q
- . ; "793 3124 123"
- . I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2)_C_WPN(3)
- ;
- ; 4 strings could include extension "301 344 2111 3424
- I IX=4 D Q:$L(WPN(0)) WPN(0)
- . I $L(WPN(1))=3,$L(WPN(2))=3,$L(WPN(3))=4 S WPN(0)=WPN(1)_WPN(2)_C_WPN(3)_C_WPN(4)
- ;
- Q ""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJPHNM 5763 printed Mar 13, 2025@20:55:42 Page 2
- BPSJPHNM ;BHAM ISC/LJF - HL7 E-Pharm Phone Number Parser ;21-NOV-2003
- +1 ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- EN(IX1,C,R) ;
- +1 ; Called with Person Index from VA(200
- +2 NEW N13,RETVAL,RETP,IX,IX2,UC,LC,PHT,SP,C3,PHD,PHDH,FLAG,PHI
- +3 ;
- +4 IF '$GET(IX1)
- QUIT ""
- +5 IF $GET(IX1)
- SET N13=$GET(^VA(200,+IX1,.13))
- +6 IF $GET(N13)=""
- QUIT ""
- +7 IF $GET(C)=""
- SET C="^"
- +8 IF $GET(R)=""
- SET R="~"
- +9 ;
- +10 ; Set up lowercase to UPPERCASE translation
- +11 SET LC="abcdefghijklmnopqrstuvwxyz"
- +12 SET UC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- +13 SET SP=" "
- SET C3=C_C_C
- +14 ;
- +15 ; home phone
- SET PHT(1)=C_"PRN"_C_"PH"_C3
- +16 ; work phone
- SET PHT(2)=C_"WPN"_C_"PH"_C3
- +17 ; 3rd phone
- SET PHT(3)=C_"WPN"_C_"PH"_C3
- +18 ; 4th phone
- SET PHT(4)=C_"WPN"_C_"PH"_C3
- +19 ; Commercial phone
- SET PHT(5)=C_"WPN"_C_"PH"_C3
- +20 ; Fax Number
- SET PHT(6)=C_"WPN"_C_"FX"_C3
- +21 ; Voice Pager Number
- SET PHT(7)=C_"BPN"_C_"BP"_C3
- +22 ; Digital Pager Number
- SET PHT(8)=C_"BPN"_C_"BP"_C3
- +23 SET (PHI(9),PHI(9,1),PHI(9,2),PHI(9,3),PHI(9,4),PHI(9,5))=""
- +24 ;
- +25 KILL PHD
- MERGE PHD=PHI
- SET PHD=$GET(^VA(200,IX1,.13))
- IF $TRANSLATE(PHD,"^ ")=""
- QUIT ""
- +26 SET PHD(10)=PHD
- +27 ; Trim leading and trailing spaces from each piece
- +28 FOR IX2=1:1:8
- Begin DoDot:1
- +29 IF $TRANSLATE($PIECE(PHD,U,IX2),SP)=""
- SET $PIECE(PHD,U,IX2)=""
- QUIT
- +30 SET PHDH=$PIECE(PHD,U,IX2)
- +31 ; remove leading spaces
- SET $PIECE(PHDH,$EXTRACT($TRANSLATE(PHDH,SP)))=""
- +32 ; remove trailing spaces
- SET PHDH=$REVERSE(PHDH)
- SET $PIECE(PHDH,$EXTRACT($TRANSLATE(PHDH,SP)))=""
- SET PHDH=$REVERSE(PHDH)
- +33 ; remove duplicate work numbers
- +34 IF IX2>1
- IF IX2<6
- Begin DoDot:2
- +35 IF $GET(PHD(11,PHDH))
- SET $PIECE(PHD,U,IX2)=""
- +36 IF '$TEST
- SET PHD(11,PHDH)=IX2
- SET $PIECE(PHD,U,IX2)=PHDH
- End DoDot:2
- QUIT
- +37 SET $PIECE(PHD,U,IX2)=PHDH
- End DoDot:1
- +38 SET PHD(10)=PHD
- +39 ;
- +40 ; Massage pagers into pieces 7&8
- +41 FOR IX2=1:1:6
- SET PHDH=$PIECE(PHD,U,IX2)
- SET FLAG=""
- IF PHDH]""
- Begin DoDot:1
- +42 IF PHDH["BEEPER"
- Begin DoDot:2
- +43 SET FLAG="1"_$PIECE(PHDH,"BEEPER",2,99)
- SET PHDH=$PIECE(PHDH,"BEEPER")
- End DoDot:2
- +44 IF PHDH["BEEP"
- Begin DoDot:2
- +45 SET FLAG="1"_$PIECE(PHDH,"BEEP",2,99)
- SET PHDH=$PIECE(PHDH,"BEEP")
- End DoDot:2
- +46 IF PHDH["BP#"
- Begin DoDot:2
- +47 SET FLAG="1"_$PIECE(PHDH,"BP#",2,99)
- SET PHDH=$PIECE(PHDH,"BP#")
- End DoDot:2
- +48 IF PHDH["BP #"
- Begin DoDot:2
- +49 SET FLAG="1"_$PIECE(PHDH,"BP #",2,99)
- SET PHDH=$PIECE(PHDH,"BP #")
- End DoDot:2
- +50 IF PHDH["BP "
- Begin DoDot:2
- +51 SET FLAG="1"_$PIECE(PHDH,"BP ",2,99)
- SET PHDH=$PIECE(PHDH,"BP ")
- End DoDot:2
- +52 IF PHDH["BP"
- Begin DoDot:2
- +53 SET FLAG="1"_$PIECE(PHDH,"BP",2,99)
- SET PHDH=$PIECE(PHDH,"BP")
- End DoDot:2
- +54 IF FLAG
- Begin DoDot:2
- +55 SET $PIECE(PHD,U,IX2)=PHDH
- SET $EXTRACT(FLAG)=""
- +56 IF $PIECE(PHD,U,8)=""
- SET $PIECE(PHD,U,8)=FLAG
- QUIT
- +57 IF $PIECE(PHD,U,7)=""
- SET $PIECE(PHD,U,7)=FLAG
- QUIT
- +58 SET $PIECE(PHD,U,8)=$PIECE(PHD,U,8)_" BP#"_FLAG
- End DoDot:2
- End DoDot:1
- +59 ;
- +60 FOR IX2=1:1:8
- SET PHD(IX2)=$PIECE(PHD,U,IX2)
- SET PHD(IX2,1)=""
- IF PHD(IX2)]""
- Begin DoDot:1
- +61 SET PHD(IX2,1)=$$RESOLVEP(PHD(IX2))
- +62 ;Init flag fields then load flags
- +63 MERGE PHD(IX2,9)=PHD(9)
- End DoDot:1
- +64 ;
- +65 SET RETVAL=""
- SET RETP=0
- +66 FOR IX2=1:1:8
- Begin DoDot:1
- +67 IF '$LENGTH(PHD(IX2))
- QUIT
- +68 IF '$LENGTH(PHD(IX2,1))
- SET $PIECE(PHD(IX2,1),U,4)=PHD(IX2)
- +69 SET PHD(IX2,1)=PHT(IX2)_PHD(IX2,1)
- +70 SET RETP=RETP+1
- SET $PIECE(RETVAL,R,RETP)=PHD(IX2,1)
- +71 QUIT
- End DoDot:1
- +72 QUIT RETVAL
- +73 ;
- RESOLVEP(PH) ;
- +1 ;
- +2 NEW WPA,WPN,WPNH,STDN,WPT,IX,STDN,PREFIX
- +3 ;
- +4 SET WPT=$TRANSLATE(PH,LC,UC)
- SET PREFIX=0
- +5 SET $PIECE(WPN,SP,$LENGTH(WPT))=SP
- SET WPA=WPN
- +6 ;
- +7 ; Separate numerics from text
- +8 FOR IX=1:1:$LENGTH(WPT)
- Begin DoDot:1
- +9 IF '$EXTRACT(WPT,IX)
- IF $EXTRACT(WPT,IX)'=0
- SET $EXTRACT(WPA,IX)=$EXTRACT(WPT,IX)
- +10 IF '$TEST
- SET $EXTRACT(WPN,IX)=$EXTRACT(PH,IX)
- End DoDot:1
- +11 ; Quit if no numerics
- +12 IF '$LENGTH($TRANSLATE(WPN,SP))
- QUIT ""
- +13 ;
- +14 ; save a copy of the numeric data
- SET WPNH=WPN
- +15 ;
- +16 ; remove leading spaces
- SET $PIECE(WPN,$EXTRACT($TRANSLATE(WPN,SP)))=""
- +17 ; remove trailing spaces
- SET WPN=$REVERSE(WPN)
- SET $PIECE(WPN,$EXTRACT($TRANSLATE(WPN,SP)))=""
- SET WPN=$REVERSE(WPN)
- +18 ; Reduce multiple spaces to single spaces
- +19 FOR IX=$LENGTH(WPN):-1:1
- IF ($EXTRACT(WPN,IX,IX+1)=(SP_SP))
- SET $EXTRACT(WPN,IX)=""
- +20 ;
- +21 ; WPN contains only NUMBERS and SPACES at this point
- +22 ; check if it is preceded by a 1 as in "1 800 345 9933"
- +23 IF $EXTRACT(WPN,1,2)="1 "
- SET $EXTRACT(WPN,1,2)=""
- SET PREFIX=2
- +24 IF 'PREFIX
- IF $EXTRACT(WPN)=1
- SET $EXTRACT(WPN)=""
- SET PREFIX=1
- +25 ; check if it's a standard 10 digit number
- +26 SET STDN=0
- +27 IF $LENGTH($TRANSLATE(WPN,SP))=10
- SET STDN=1
- Begin DoDot:1
- +28 ; format: 1234567890
- IF $LENGTH(WPN)=10
- Begin DoDot:2
- +29 SET WPN(1)=$EXTRACT(WPN,1,3)
- SET WPN(2)=$EXTRACT(WPN,4,6)
- SET WPN(3)=$EXTRACT(WPN,7,10)
- +30 IF PH[WPN(1)
- IF PH[WPN(2)
- IF PH[WPN(3)
- +31 IF '$TEST
- SET STDN=0
- End DoDot:2
- IF STDN=1
- QUIT
- +32 SET STDN=1
- +33 ; format: 123 456 7890
- IF $LENGTH(WPN,SP)=3
- Begin DoDot:2
- +34 SET WPN(1)=$PIECE(WPN,SP,1)
- SET WPN(2)=$PIECE(WPN,SP,2)
- SET WPN(3)=$PIECE(WPN,SP,3)
- +35 IF $LENGTH(WPN(1))=3
- IF PH[WPN(1)
- IF $LENGTH(WPN(2))=3
- IF PH[WPN(2)
- IF $LENGTH(WPN(3))=4
- IF PH[WPN(3)
- +36 IF '$TEST
- SET STDN=0
- End DoDot:2
- IF STDN
- QUIT
- +37 SET STDN=1
- +38 ; Still may be salvageable
- IF $LENGTH(WPN,SP)=2
- Begin DoDot:2
- +39 SET WPN(1)=$PIECE(WPN,SP,1)
- SET WPN(2)=$PIECE(WPN,SP,2)
- +40 ; is format "123 4567890"? area code & city/phone
- +41 IF $LENGTH(WPN(1))=3
- SET WPN(3)=$EXTRACT(WPN(2),4,7)
- SET $EXTRACT(WPN(2),4,7)=""
- QUIT
- +42 ; is format "123456 7890"? area/city code & phone
- +43 IF $LENGTH(WPN(1))=6
- SET WPN(3)=WPN(2)
- SET WPN(2)=$EXTRACT(WPN(1),4,6)
- SET $EXTRACT(WPN(1),4,6)=""
- QUIT
- +44 ;unsalvageable as standard number
- SET STDN=0
- End DoDot:2
- IF STDN=1
- QUIT
- +45 ;unsalvageable as standard number
- SET STDN=0
- End DoDot:1
- +46 ;
- +47 ; Quit if standard format
- +48 IF STDN
- QUIT WPN(1)_WPN(2)_C_WPN(3)
- +49 ;
- +50 ;Not standard, need to do some work
- +51 ;
- +52 FOR IX=1:1:$LENGTH(WPN,SP)
- SET WPN(IX)=$PIECE(WPN,SP,IX)
- +53 SET IX=$LENGTH(WPN,SP)
- SET WPN(0)=""
- +54 ;
- +55 ; add prefix back in if applicable
- +56 IF PREFIX=1
- IF $LENGTH(WPN(1))'=10
- SET WPN(1)="1"_WPN(1)
- +57 ;
- +58 ; 1 string of digits
- +59 IF IX=1
- Begin DoDot:1
- +60 ;assume it's an extension
- IF $LENGTH(WPN(1))<7
- SET WPN(0)=C_C_WPN(1)
- QUIT
- +61 ;city code & local number
- IF $LENGTH(WPN(1))=7
- SET WPN(0)=$EXTRACT(WPN(1),1,3)_C_$EXTRACT(WPN(1),4,7)
- QUIT
- End DoDot:1
- if $LENGTH(WPN(0))
- QUIT WPN(0)
- +62 ;
- +63 ; 2 strings of digits
- +64 IF IX=2
- Begin DoDot:1
- +65 ; could be city code & local number
- +66 IF $LENGTH(WPN(1))=3
- IF $LENGTH(WPN(2))=4
- SET WPN(0)=WPN(1)_C_WPN(2)
- QUIT
- +67 ; could be full number plus extension
- +68 IF $LENGTH(WPN(1))=10
- SET WPN(0)=$EXTRACT(WPN(1),1,6)_C_$EXTRACT(WPN(1),7,10)_C_WPN(2)
- End DoDot:1
- if $LENGTH(WPN(0))
- QUIT WPN(0)
- +69 ;
- +70 ; 3 strings could include extension
- +71 IF IX=3
- Begin DoDot:1
- +72 ; "301 7933124 123"
- +73 IF $LENGTH(WPN(1))=3
- IF $LENGTH(WPN(2))=7
- SET WPN(0)=WPN(1)_$EXTRACT(WPN(2),1,3)_C_$EXTRACT(WPN(2),4,7)_C_WPN(3)
- QUIT
- +74 ; "793 3124 123"
- +75 IF $LENGTH(WPN(1))=3
- IF $LENGTH(WPN(2))=4
- SET WPN(0)=WPN(1)_C_WPN(2)_C_WPN(3)
- End DoDot:1
- if $LENGTH(WPN(0))
- QUIT WPN(0)
- +76 ;
- +77 ; 4 strings could include extension "301 344 2111 3424
- +78 IF IX=4
- Begin DoDot:1
- +79 IF $LENGTH(WPN(1))=3
- IF $LENGTH(WPN(2))=3
- IF $LENGTH(WPN(3))=4
- SET WPN(0)=WPN(1)_WPN(2)_C_WPN(3)_C_WPN(4)
- End DoDot:1
- if $LENGTH(WPN(0))
- QUIT WPN(0)
- +80 ;
- +81 QUIT ""
