LEXAR7 ;ISL/KER - Look-up Response (MAIL) ;04/21/2014
;;2.0;LEXICON UTILITY;**9,25,73,80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXMSG") SACC 2.3.2.5.1
; ^TMP("LEXSEND") SACC 2.3.2.5.1
;
; External References
; HOME^%ZIS ICR 10086
; ^%ZTLOAD ICR 10063
; ^DIK ICR 10013
;
; This routines sends a Mailman message containing the Unresolved
; Narratives and Comments stored in file 757.06 to the Field Office
; at G.LEXUNR@ISC-SLC.DOMAIN.EXT. Once sent, the Unresolved Narratives
; and comments are purged from file 757.06. Both the Unresolved
; Narratives and comments are used to update the Lexicon Utility.
;
Q
SEND ; Task MAILMAN to Send Unresolved Narratives to the ISC
I +($$TOT^LEXAR6)'>49!('$L($G(^LEX(757.06,0))))!(+($P($G(^LEX(757.06,0)),"^",4))<1) G SENDQ
G:$D(^TMP("LEXSEND")) SENDQ S ^TMP("LEXSEND",$J)=""
N X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,%,%X,%Y
S ZTRTN="ISC^LEXAR7",ZTDESC="Sending Narratives to IRMFO",ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS
SENDQ ; End of Send
K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
Q
DUMP ; Dump Narratives to Developer
D HOME^%ZIS S U="^" Q:+($G(DUZ))=0 Q:+($O(^LEX(757.06,0)))'>0
S ^TMP("LEXSEND",$J)="" K ^TMP("LEXMSG",$J) D ISC K ^TMP("LEXSEND",$J)
Q
ISC ; Create MAILMAN Message for the IRMFO
G:'$D(^TMP("LEXSEND")) ISCQ G:$D(^TMP("LEXMSG")) ISCQ
;
; LEXT Narrative Type
; LEXN Narrative
; LEXA # of Narratives Added to Message
;
N DA,DIC,DIK,DIE,X,Y,LEXT,LEXN,LEXA S:$D(ZTQUEUED) ZTREQ="@" D INM S DA=0,DIK="^LEX(757.06,",LEXA=0
F S DA=$O(^LEX(757.06,DA)) Q:+DA=0 D
. S LEXT="UNR"
. I '$D(^LEX(757.06,DA,1)),'$D(^LEX(757.06,DA,2)),'$D(^LEX(757.06,DA,3)),$D(^LEX(757.06,DA,4)) S LEXT="COM"
. Q:+($G(^LEX(757.06,DA,99)))'>0
. S LEXN=$P($G(^LEX(757.06,DA,0)),"^",1) Q:'$L(LEXN) Q:'$D(^LEX(757.06,"B",$E(LEXN,1,30),DA))
. Q:+($G(LEXA))>50
. D ADD(" ",LEXT) S LEXA=LEXA+1
. I $L($P($G(^LEX(757.06,DA,0)),U,1)) D
. . I LEXT="UNR" D ADD("NAR",$P($G(^LEX(757.06,DA,0)),U,1,2)) Q
. . D ADD("EXP",$P($G(^LEX(757.06,DA,0)),U,1)) Q
. D:$L($P($G(^LEX(757.06,DA,0)),U,3)) ADD("SCH",$P($G(^LEX(757.06,DA,0)),U,3))
. D:$L($P($G(^LEX(757.06,DA,0)),U,4)) ADD("FND",$P($G(^LEX(757.06,DA,0)),U,4))
. D:$L($P($G(^LEX(757.06,DA,1)),U,1)) ADD("APP",$P($G(^LEX(757.06,DA,1)),U,1))
. D:$L($P($G(^LEX(757.06,DA,1)),U,2)) ADD("SER",$P($G(^LEX(757.06,DA,1)),U,2))
. D:$L($P($G(^LEX(757.06,DA,1)),U,3)) ADD("LOC",$P($G(^LEX(757.06,DA,1)),U,3))
. D:$L($P($G(^LEX(757.06,DA,2)),U,1)) ADD("FLN",$P($G(^LEX(757.06,DA,2)),U,1))
. D:$L($P($G(^LEX(757.06,DA,2)),U,2)) ADD("IDX",$P($G(^LEX(757.06,DA,2)),U,2))
. D:$L($P($G(^LEX(757.06,DA,2)),U,3)) ADD("SCT",$P($G(^LEX(757.06,DA,2)),U,3))
. D:$L($G(^LEX(757.06,DA,3))) ADD("SCR",$G(^LEX(757.06,DA,3)))
. D:$L($P($G(^LEX(757.06,DA,4)),U,1)) ADD("IEN",$P($G(^LEX(757.06,DA,4)),U,1))
. D:$L($P($G(^LEX(757.06,DA,4)),U,2)) ADD("COM",$P($G(^LEX(757.06,DA,4)),U,2))
. I +($G(DA))>0 K ^LEX(757.06,+($G(DA)),99) D:$D(^LEX(757.06,+($G(DA)),0)) ^DIK
D N0,MAIL S LEXA=$$TOT^LEXAR6
ISCQ ; End of Send MAILMAN Message
K LEXA,LEXN,LEXT S:$D(ZTQUEUED) ZTREQ="@"
Q
ADD(LEXI,LEXS) ; Add text to message
;
; LEXI Narrative Segment ID
; LEXS Segment String
; LEXC Counter/IEN for ^TMP("LEXMSG",$J,LEXC)
;
N LEXC S LEXC=+($G(^TMP("LEXMSG",$J,0)))+1,^TMP("LEXMSG",$J,0)=LEXC,^TMP("LEXMSG",$J,LEXC)=LEXI
S:$G(LEXS)'="" ^TMP("LEXMSG",$J,LEXC)=^TMP("LEXMSG",$J,LEXC)_"^"_LEXS
Q
MAIL ; MAILMAN
N XCNP,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y,LEXADR S LEXADR=$$ADR^LEXU G:'$L(LEXADR) MAILQ
G:'$D(^TMP("LEXMSG",$J)) MAILQ G:+($G(LEXA))=0 MAILQ G:+($G(^TMP("LEXMSG",$J,0)))=0 MAILQ
K XMZ N DIFROM S XMSUB="Unresolved Narratives - "_LEXA_" items"
S XMY(("G.LEXUNR@"_LEXADR))="",XMTEXT="^TMP(""LEXMSG"",$J,",XMDUZ=.5
; Patch 57, discontinue the transmission of Unresolved Narratives
; D ^XMD
MAILQ ; End of MAILMAN
K ^TMP("LEXSEND",$J),^TMP("LEXMSG",$J),DIFROM,LEXA,XCNP,XMDUZ,XMZ,XMSUB,XMY,XMTEXT,XMDUZ,XMSCR,REF, Q
INM ; Initialize Message
N LEXI S (LEXI,^TMP("LEXMSG",$J,0))=0 F S LEXI=$O(^TMP("LEXMSG",$J,LEXI)) Q:+LEXI=0 K ^TMP("LEXMSG",$J,LEXI)
Q
N0 ; ^LEX(757.06,0)
N LEX3,LEX4,DA S (LEX3,LEX4,DA)=0 F S DA=$O(^LEX(757.06,DA)) Q:+DA=0 S LEX3=DA,LEX4=LEX4+1
S LEX3=+LEX3,LEX4=+LEX4 S:+LEX3=0 LEX3="" S:+LEX4=0 LEX4="" S ^LEX(757.06,0)=$P($G(^LEX(757.06,0)),"^",1,2)_"^"_LEX3_"^"_LEX4
Q
CLR ; Clear all narratives
N DA,DIK S DA=0,U="^",DIK="^LEX(757.06," F S DA=$O(^LEX(757.06,DA)) Q:+DA=0 D ^DIK
N LEXN S LEXN=$P(^LEX(757.06,0),"^",1,2)_"^^" S ^LEX(757.06,0)=LEXN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAR7 4723 printed Apr 09, 2024@21:12:14 Page 2
LEXAR7 ;ISL/KER - Look-up Response (MAIL) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**9,25,73,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXMSG") SACC 2.3.2.5.1
+5 ; ^TMP("LEXSEND") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; HOME^%ZIS ICR 10086
+9 ; ^%ZTLOAD ICR 10063
+10 ; ^DIK ICR 10013
+11 ;
+12 ; This routines sends a Mailman message containing the Unresolved
+13 ; Narratives and Comments stored in file 757.06 to the Field Office
+14 ; at G.LEXUNR@ISC-SLC.DOMAIN.EXT. Once sent, the Unresolved Narratives
+15 ; and comments are purged from file 757.06. Both the Unresolved
+16 ; Narratives and comments are used to update the Lexicon Utility.
+17 ;
+18 QUIT
SEND ; Task MAILMAN to Send Unresolved Narratives to the ISC
+1 IF +($$TOT^LEXAR6)'>49!('$LENGTH($GET(^LEX(757.06,0))))!(+($PIECE($GET(^LEX(757.06,0)),"^",4))<1)
GOTO SENDQ
+2 if $DATA(^TMP("LEXSEND"))
GOTO SENDQ
SET ^TMP("LEXSEND",$JOB)=""
+3 NEW X,Y,ZTQUEUED,ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,%,%X,%Y
+4 SET ZTRTN="ISC^LEXAR7"
SET ZTDESC="Sending Narratives to IRMFO"
SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
SENDQ ; End of Send
+1 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN
+2 QUIT
DUMP ; Dump Narratives to Developer
+1 DO HOME^%ZIS
SET U="^"
if +($GET(DUZ))=0
QUIT
if +($ORDER(^LEX(757.06,0)))'>0
QUIT
+2 SET ^TMP("LEXSEND",$JOB)=""
KILL ^TMP("LEXMSG",$JOB)
DO ISC
KILL ^TMP("LEXSEND",$JOB)
+3 QUIT
ISC ; Create MAILMAN Message for the IRMFO
+1 if '$DATA(^TMP("LEXSEND"))
GOTO ISCQ
if $DATA(^TMP("LEXMSG"))
GOTO ISCQ
+2 ;
+3 ; LEXT Narrative Type
+4 ; LEXN Narrative
+5 ; LEXA # of Narratives Added to Message
+6 ;
+7 NEW DA,DIC,DIK,DIE,X,Y,LEXT,LEXN,LEXA
if $DATA(ZTQUEUED)
SET ZTREQ="@"
DO INM
SET DA=0
SET DIK="^LEX(757.06,"
SET LEXA=0
+8 FOR
SET DA=$ORDER(^LEX(757.06,DA))
if +DA=0
QUIT
Begin DoDot:1
+9 SET LEXT="UNR"
+10 IF '$DATA(^LEX(757.06,DA,1))
IF '$DATA(^LEX(757.06,DA,2))
IF '$DATA(^LEX(757.06,DA,3))
IF $DATA(^LEX(757.06,DA,4))
SET LEXT="COM"
+11 if +($GET(^LEX(757.06,DA,99)))'>0
QUIT
+12 SET LEXN=$PIECE($GET(^LEX(757.06,DA,0)),"^",1)
if '$LENGTH(LEXN)
QUIT
if '$DATA(^LEX(757.06,"B",$EXTRACT(LEXN,1,30),DA))
QUIT
+13 if +($GET(LEXA))>50
QUIT
+14 DO ADD(" ",LEXT)
SET LEXA=LEXA+1
+15 IF $LENGTH($PIECE($GET(^LEX(757.06,DA,0)),U,1))
Begin DoDot:2
+16 IF LEXT="UNR"
DO ADD("NAR",$PIECE($GET(^LEX(757.06,DA,0)),U,1,2))
QUIT
+17 DO ADD("EXP",$PIECE($GET(^LEX(757.06,DA,0)),U,1))
QUIT
End DoDot:2
+18 if $LENGTH($PIECE($GET(^LEX(757.06,DA,0)),U,3))
DO ADD("SCH",$PIECE($GET(^LEX(757.06,DA,0)),U,3))
+19 if $LENGTH($PIECE($GET(^LEX(757.06,DA,0)),U,4))
DO ADD("FND",$PIECE($GET(^LEX(757.06,DA,0)),U,4))
+20 if $LENGTH($PIECE($GET(^LEX(757.06,DA,1)),U,1))
DO ADD("APP",$PIECE($GET(^LEX(757.06,DA,1)),U,1))
+21 if $LENGTH($PIECE($GET(^LEX(757.06,DA,1)),U,2))
DO ADD("SER",$PIECE($GET(^LEX(757.06,DA,1)),U,2))
+22 if $LENGTH($PIECE($GET(^LEX(757.06,DA,1)),U,3))
DO ADD("LOC",$PIECE($GET(^LEX(757.06,DA,1)),U,3))
+23 if $LENGTH($PIECE($GET(^LEX(757.06,DA,2)),U,1))
DO ADD("FLN",$PIECE($GET(^LEX(757.06,DA,2)),U,1))
+24 if $LENGTH($PIECE($GET(^LEX(757.06,DA,2)),U,2))
DO ADD("IDX",$PIECE($GET(^LEX(757.06,DA,2)),U,2))
+25 if $LENGTH($PIECE($GET(^LEX(757.06,DA,2)),U,3))
DO ADD("SCT",$PIECE($GET(^LEX(757.06,DA,2)),U,3))
+26 if $LENGTH($GET(^LEX(757.06,DA,3)))
DO ADD("SCR",$GET(^LEX(757.06,DA,3)))
+27 if $LENGTH($PIECE($GET(^LEX(757.06,DA,4)),U,1))
DO ADD("IEN",$PIECE($GET(^LEX(757.06,DA,4)),U,1))
+28 if $LENGTH($PIECE($GET(^LEX(757.06,DA,4)),U,2))
DO ADD("COM",$PIECE($GET(^LEX(757.06,DA,4)),U,2))
+29 IF +($GET(DA))>0
KILL ^LEX(757.06,+($GET(DA)),99)
if $DATA(^LEX(757.06,+($GET(DA)),0))
DO ^DIK
End DoDot:1
+30 DO N0
DO MAIL
SET LEXA=$$TOT^LEXAR6
ISCQ ; End of Send MAILMAN Message
+1 KILL LEXA,LEXN,LEXT
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
ADD(LEXI,LEXS) ; Add text to message
+1 ;
+2 ; LEXI Narrative Segment ID
+3 ; LEXS Segment String
+4 ; LEXC Counter/IEN for ^TMP("LEXMSG",$J,LEXC)
+5 ;
+6 NEW LEXC
SET LEXC=+($GET(^TMP("LEXMSG",$JOB,0)))+1
SET ^TMP("LEXMSG",$JOB,0)=LEXC
SET ^TMP("LEXMSG",$JOB,LEXC)=LEXI
+7 if $GET(LEXS)'=""
SET ^TMP("LEXMSG",$JOB,LEXC)=^TMP("LEXMSG",$JOB,LEXC)_"^"_LEXS
+8 QUIT
MAIL ; MAILMAN
+1 NEW XCNP,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y,LEXADR
SET LEXADR=$$ADR^LEXU
if '$LENGTH(LEXADR)
GOTO MAILQ
+2 if '$DATA(^TMP("LEXMSG",$JOB))
GOTO MAILQ
if +($GET(LEXA))=0
GOTO MAILQ
if +($GET(^TMP("LEXMSG",$JOB,0)))=0
GOTO MAILQ
+3 KILL XMZ
NEW DIFROM
SET XMSUB="Unresolved Narratives - "_LEXA_" items"
+4 SET XMY(("G.LEXUNR@"_LEXADR))=""
SET XMTEXT="^TMP(""LEXMSG"",$J,"
SET XMDUZ=.5
+5 ; Patch 57, discontinue the transmission of Unresolved Narratives
+6 ; D ^XMD
MAILQ ; End of MAILMAN
+1 KILL ^TMP("LEXSEND",$JOB),^TMP("LEXMSG",$JOB),DIFROM,LEXA,XCNP,XMDUZ,XMZ,XMSUB,XMY,XMTEXT,XMDUZ,XMSCR,REF,
QUIT
INM ; Initialize Message
+1 NEW LEXI
SET (LEXI,^TMP("LEXMSG",$JOB,0))=0
FOR
SET LEXI=$ORDER(^TMP("LEXMSG",$JOB,LEXI))
if +LEXI=0
QUIT
KILL ^TMP("LEXMSG",$JOB,LEXI)
+2 QUIT
N0 ; ^LEX(757.06,0)
+1 NEW LEX3,LEX4,DA
SET (LEX3,LEX4,DA)=0
FOR
SET DA=$ORDER(^LEX(757.06,DA))
if +DA=0
QUIT
SET LEX3=DA
SET LEX4=LEX4+1
+2 SET LEX3=+LEX3
SET LEX4=+LEX4
if +LEX3=0
SET LEX3=""
if +LEX4=0
SET LEX4=""
SET ^LEX(757.06,0)=$PIECE($GET(^LEX(757.06,0)),"^",1,2)_"^"_LEX3_"^"_LEX4
+3 QUIT
CLR ; Clear all narratives
+1 NEW DA,DIK
SET DA=0
SET U="^"
SET DIK="^LEX(757.06,"
FOR
SET DA=$ORDER(^LEX(757.06,DA))
if +DA=0
QUIT
DO ^DIK
+2 NEW LEXN
SET LEXN=$PIECE(^LEX(757.06,0),"^",1,2)_"^^"
SET ^LEX(757.06,0)=LEXN
+3 QUIT
