- LEXAR7 ;ISL/KER - Look-up Response (MAIL) ;04/21/2014
- ;;2.0;LEXICON UTILITY;**9,25,73,80**;Sep 23, 1996;Build 10
- ;
- ; 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.VA.GOV. 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
- LEXAR7 ;ISL/KER - Look-up Response (MAIL) ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**9,25,73,80**;Sep 23, 1996;Build 10
- +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.VA.GOV. 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
