XMDIR1A ;(WASH ISC)/CAP-Load VACO Directories (WANG) ;04/17/2002 08:47
;;8.0;MailMan;;Jun 28, 2002
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP=""
S X="EOF^XMDIR1A",@^%ZOSF("TRAP"),XMB0=^%ZOSF("UPPERCASE")
G P:'$D(ZTQUEUED)
;Batch processing begins here
R1 U IO R Y:DTIME I '$D(ZTQUEUED) U IO(0)
S XMA=XMA+1 I '$D(ZTQUEUED),XMA#10=0 W "."
P S X=Y X XMB0 F %=0:0 Q:$E(Y)'?1P S Y=$E(Y,2,99)
F %=$L(Y):-1:0 Q:$E(Y,%)?1A S Y=$E(Y,1,%-1)
K X S X=$P(Y,"*")
G R1:X[" ",R1:X["@",R1:X["::",R1:X[".."
S XMY=Y
;
1 ;Name
S X("LN")=$P(X,".",$L(X,".")),X=$P(X,".",1,$L(X,".")-1)
G R1:'$L(X("LN")),R1:X("LN")?1.N,R1:X("LN")?.E3N.E,R1:X("LN")["/"
G R1:X("LN")?.E1C.E
S X("FN")=$P(X,"."),X=$P(X,".",2,9),X("RN")=X
;
;Mail code
S X=$P(Y,"*",2),X("MC")=$P(X," "),X("EMC")=X G R1:X("MC")?.E1C.E
;
;Location
S X("L")=$P(Y,"*",3)
;
;Network address
S Y=$P(XMY,"*") G R1:'$L(Y),R1:Y?.E1C.E S X("NET")=Y_"@VACOWMAIL.DOMAIN.EXT"
I $D(^XMD(4.2997,"B",X("LN"))) S %="" F S %=$O(^XMD(4.2997,"B",X("LN"),%)) Q:%="" I $D(^XMD(4.2997,%,0)) S %6=^XMD(4.2997,%,0) I X("NET")=$P(%6,U,7) S XME="Already on file - not filed " D ER^XMDIR1 G R1
;
D FILE(.X)
G R1
FILE(X) ;HARD CODE
;
;X("EMC")=Extended Mail Code
;X("FN")=First name
;X("L")=Location
;X("LN")=Last name
;X("MC")=Mail Code
;X("NET")=full NETwork address
;X("PHONE")=Phone number
;X("PHONE/E")=Telephone Extension
;X("RN")=Restofname
;
;Get new entry number
N %,N,Y L +^XMD(4.2997,0)
S Y=^XMD(4.2997,0) F N=$P(Y,U,4)+1:1 Q:'$D(^(N))
L +^XMD(4.2997,N) S $P(Y,U,4)=N,^XMD(4.2997,0)=Y
;File entry
S ^XMD(4.2997,N,0)=X("LN")_U_X("FN")_U_X("RN")_U_X("MC")_U_X("EMC")_U_X("L")_U_X("NET")_U_+$H_U_XMDIR1,^("AUTO")=XMDIR1A("CODE")
I $D(X("PHONE"))!$D(X("PHONE/X")) S %=$G(X("PHONE")) S:$L($G(X("PHONE/X"))) %=%_U_X("PHONE/X") S ^XMD(4.2997,N,1)=%
;Create cross references for one entry
S DIK="^XMD(4.2997,",DA=N D IX^DIK L -^XMD(4.2997,0),-^XMD(4.2997,N)
Q
EOF D ^%ZISC,END("WANG",90) Q
END(X,Y) ;END PROCESSING
;X=NAME OF FILE (WANG or NOAVA)
;Y=Subscript of text array
N A S A=X,XMDIR1($E(X))=XMA
S ^TMP("XMDIR1",$J,.01)="Normal error reported here",^(.02)="("_$ZE_")",^(.03)="should be end of File."
S ^TMP("XMDIR1",$J,.04)="Done processing "_A_" file on "_$$HTE^XLFDT($H,5)
S ^TMP("XMDIR1",$J,.05)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMDIR1A 2347 printed Dec 13, 2024@02:11:32 Page 2
XMDIR1A ;(WASH ISC)/CAP-Load VACO Directories (WANG) ;04/17/2002 08:47
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP=""
+3 SET X="EOF^XMDIR1A"
SET @^%ZOSF("TRAP")
SET XMB0=^%ZOSF("UPPERCASE")
+4 if '$DATA(ZTQUEUED)
GOTO P
+5 ;Batch processing begins here
R1 USE IO
READ Y:DTIME
IF '$DATA(ZTQUEUED)
USE IO(0)
+1 SET XMA=XMA+1
IF '$DATA(ZTQUEUED)
IF XMA#10=0
WRITE "."
P SET X=Y
XECUTE XMB0
FOR %=0:0
if $EXTRACT(Y)'?1P
QUIT
SET Y=$EXTRACT(Y,2,99)
+1 FOR %=$LENGTH(Y):-1:0
if $EXTRACT(Y,%)?1A
QUIT
SET Y=$EXTRACT(Y,1,%-1)
+2 KILL X
SET X=$PIECE(Y,"*")
+3 if X[" "
GOTO R1
if X["@"
GOTO R1
if X["::"
GOTO R1
if X[".."
GOTO R1
+4 SET XMY=Y
+5 ;
1 ;Name
+1 SET X("LN")=$PIECE(X,".",$LENGTH(X,"."))
SET X=$PIECE(X,".",1,$LENGTH(X,".")-1)
+2 if '$LENGTH(X("LN"))
GOTO R1
if X("LN")?1.N
GOTO R1
if X("LN")?.E3N.E
GOTO R1
if X("LN")["/"
GOTO R1
+3 if X("LN")?.E1C.E
GOTO R1
+4 SET X("FN")=$PIECE(X,".")
SET X=$PIECE(X,".",2,9)
SET X("RN")=X
+5 ;
+6 ;Mail code
+7 SET X=$PIECE(Y,"*",2)
SET X("MC")=$PIECE(X," ")
SET X("EMC")=X
if X("MC")?.E1C.E
GOTO R1
+8 ;
+9 ;Location
+10 SET X("L")=$PIECE(Y,"*",3)
+11 ;
+12 ;Network address
+13 SET Y=$PIECE(XMY,"*")
if '$LENGTH(Y)
GOTO R1
if Y?.E1C.E
GOTO R1
SET X("NET")=Y_"@VACOWMAIL.DOMAIN.EXT"
+14 IF $DATA(^XMD(4.2997,"B",X("LN")))
SET %=""
FOR
SET %=$ORDER(^XMD(4.2997,"B",X("LN"),%))
if %=""
QUIT
IF $DATA(^XMD(4.2997,%,0))
SET %6=^XMD(4.2997,%,0)
IF X("NET")=$PIECE(%6,U,7)
SET XME="Already on file - not filed "
DO ER^XMDIR1
GOTO R1
+15 ;
+16 DO FILE(.X)
+17 GOTO R1
FILE(X) ;HARD CODE
+1 ;
+2 ;X("EMC")=Extended Mail Code
+3 ;X("FN")=First name
+4 ;X("L")=Location
+5 ;X("LN")=Last name
+6 ;X("MC")=Mail Code
+7 ;X("NET")=full NETwork address
+8 ;X("PHONE")=Phone number
+9 ;X("PHONE/E")=Telephone Extension
+10 ;X("RN")=Restofname
+11 ;
+12 ;Get new entry number
+13 NEW %,N,Y
LOCK +^XMD(4.2997,0)
+14 SET Y=^XMD(4.2997,0)
FOR N=$PIECE(Y,U,4)+1:1
if '$DATA(^(N))
QUIT
+15 LOCK +^XMD(4.2997,N)
SET $PIECE(Y,U,4)=N
SET ^XMD(4.2997,0)=Y
+16 ;File entry
+17 SET ^XMD(4.2997,N,0)=X("LN")_U_X("FN")_U_X("RN")_U_X("MC")_U_X("EMC")_U_X("L")_U_X("NET")_U_+$HOROLOG_U_XMDIR1
SET ^("AUTO")=XMDIR1A("CODE")
+18 IF $DATA(X("PHONE"))!$DATA(X("PHONE/X"))
SET %=$GET(X("PHONE"))
if $LENGTH($GET(X("PHONE/X")))
SET %=%_U_X("PHONE/X")
SET ^XMD(4.2997,N,1)=%
+19 ;Create cross references for one entry
+20 SET DIK="^XMD(4.2997,"
SET DA=N
DO IX^DIK
LOCK -^XMD(4.2997,0),-^XMD(4.2997,N)
+21 QUIT
EOF DO ^%ZISC
DO END("WANG",90)
QUIT
END(X,Y) ;END PROCESSING
+1 ;X=NAME OF FILE (WANG or NOAVA)
+2 ;Y=Subscript of text array
+3 NEW A
SET A=X
SET XMDIR1($EXTRACT(X))=XMA
+4 SET ^TMP("XMDIR1",$JOB,.01)="Normal error reported here"
SET ^(.02)="("_$ZE_")"
SET ^(.03)="should be end of File."
+5 SET ^TMP("XMDIR1",$JOB,.04)="Done processing "_A_" file on "_$$HTE^XLFDT($HOROLOG,5)
+6 SET ^TMP("XMDIR1",$JOB,.05)=""
+7 QUIT
