- 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 Feb 18, 2025@23:37:42 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
