ECXTRANS ;ALB/GTS,JAP,BIR/DMA-Extract from Local Editing Files and Transmit ;3/29/17 15:15
;;3.0;DSS EXTRACTS;**2,9,12,8,13,14,23,24,33,49,54,75,71,144,149,166**;Dec 22, 1997;Build 24
EN ;entry point
N ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,JJ,SS,OUT,DIR,DUOUT,ECXTREC ;166
N DTOUT,DIRUT,DIC,X,Y,ECXLOGIC,ECSD,FODMN
S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",1)
I ECXQUEUE'?1"DM"1U D Q
.W !,"You have not defined a proper transmission queue"
.W !,"for entry number 1 in the DSS EXTRACTS file (#728)."
.W !,"No transmission allowed."
.D PAUSE
;** check divisions for transmission
S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
I 'ECCHK D Q
.W !,"You do not have any divisions defined in your user set up and cannot transmit."
.S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
W !!,"Your user setup will only allow you to transmit extracts from the"
W !,"following divisions:",!
S ECDIVVR=""
F S ECDIVVR=$O(ECTMP(ECDIVVR)) Q:'(+ECDIVVR) D
.K ECXDIC S DA=ECDIVVR,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01"
.D EN^DIQ1 W !," ",$G(ECXDIC(4,DA,.01,"I")) K DIC,DIQ,DA,DR,ECXDIC
W !!,"If you can't select an extract, it is probably from another division.",!
D PAUSE Q:OUT
AGAIN S ECRE="",DIC="^ECX(727,",DIC(0)="AEQM"
N ECTYPE
S DIC("A")="Transmit which extract: "
S DIC("S")="I '$D(^ECX(727,+Y,""L"")),'$D(^ECX(727,+Y,""PURG"")),$D(ECTMP(+$P($G(^ECX(727,+Y,""DIV"")),U,1)))"
S DIC("W")="W:$G(DZ)[""?"" ?12,$E($P(^(0),U,2),4,5)_""-""_$E($P(^(0),U,2),6,7)_""-""_$E($P(^(0),U,2),2,3),?21,$P(^(0),U,3),?48,""Records Extracted: "",$S($P(^(0),U,6)'="""":$P(^(0),U,6),1:""Inc."")" ;166
D ^DIC
I Y<0 W !! Q
S ECXTREC=$P($G(^ECX(727,+Y,0)),U,6) ;166
I '+ECXTREC D Q ;166
.W !!,$$REPEAT^XLFSTR("*",80)
.W !,"* You may not transmit this extract because ",$S(ECXTREC="":"it hasn't finished processing.",1:"it has 0 records."),?79,"*" ;166
.W !,"* Please check your selected extract to be sure it ",$S(ECXTREC="":"has completed.",1:"has at least one record."),?79,"*" ;166
.W !,$$REPEAT^XLFSTR("*",80)
.Q ;166
;get data on extract
S DR="1;2;3;4;5;6;14;15",(ECDA,DA)=+Y,DIQ(0)="IE",DIQ="ECXDIQ" D EN^DIQ1
I ECXDIQ(727,ECDA,14,"I")="" D
.S ECXDIQ(727,ECDA,14,"I")=$$FISCAL^ECXUTL1(ECXDIQ(727,ECDA,3,"I"))
.S ECXDIQ(727,ECDA,14,"E")=ECXDIQ(727,ECDA,14,"I")
S ECXLOGIC=ECXDIQ(727,ECDA,14,"I")
S ECSD=ECXDIQ(727,ECDA,3,"I")
W !!,ECXDIQ(727,ECDA,6,"E")_" Extract (#"_ECDA_")",?42,"Records: ",ECXDIQ(727,ECDA,5,"E")
W !,"Generated on: ",ECXDIQ(727,ECDA,1,"E"),?42,"Start date: ",ECXDIQ(727,ECDA,3,"E")
W !,"Division: ",$E(ECXDIQ(727,ECDA,15,"E"),1,26),?42,"End date: ",ECXDIQ(727,ECDA,4,"E")
S X=$E(ECXDIQ(727,ECDA,14,"I"),5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ")
W !!,"The data was extracted using "_X_"fiscal year "_$E(ECXDIQ(727,ECDA,14,"I"),1,4)_" logic."
W !!,"MailMan transmission of the "_ECXDIQ(727,ECDA,2,"E")_" extract is set to a"
W !,"limit of 131,000 bytes per message. Each extract record ends with a ^~."
I $G(^ECX(727,ECDA,"TR")) S ECX=^("TR") D Q:OUT
.S OUT=0
.W !!,"This extract was transmitted on ",$TR($$FMTE^XLFDT(ECX,"5DF")," ","0")
.K ECX S DIR(0)="Y",DIR("A")="Do you want to retransmit " D ^DIR K DIR
.I 'Y S OUT=1 Q
.K ^ECX(727,ECDA,"TR")
.S ECRE="re"
S ECTYPE=$P(^ECX(727,ECDA,0),U,3),ECIEN=+$O(^ECX(727.1,"AC",ECTYPE,0))
S ECPIECE=$P($G(^ECX(727.1,ECIEN,0)),U,10)
I ECPIECE>0,$P($G(^ECX(728,1,7.1)),U,ECPIECE)]"" D Q
.D MES^XPDUTL(" ")
.D MES^XPDUTL("An "_ECTYPE_" Extract is currently running or scheduled to run.")
.D MES^XPDUTL("Please wait until that job has completed before attempting")
.D MES^XPDUTL("this transmission.")
.D MES^XPDUTL(" ")
.D PAUSE
S ZTSK=$G(^ECX(727,ECDA,"Q"))
I ZTSK D STAT^%ZTLOAD I ZTSK(0) I ZTSK(1)<3 D Q
.W !!,"Task ",ZTSK," is already queued to transmit this extract."
.K ZTSK
.D PAUSE
S FODMN=$$FODMN()
;Field office reminder
I FODMN D
.W !
.W !,"** This extract is being sent from a field office domain. **"
.W !,"** Extract message(s) will only be delivered to you and **"
.W !,"** will be placed into your 'DSSXMIT' mail basket. **"
.W !
.;Ensure user has a DSSXMIT mail basket
.N TMPARR
.D LISTBSKT^XMXAPIB(DUZ,,,,"DSSXMIT","TMPARR")
.I '$D(TMPARR("XMLIST","BSKT","DSSXMIT")) D
..;Create DSSXMIT basket
..N IEN,XMERR
..D CRE8BSKT^XMXAPIB(DUZ,"DSSXMIT",.IEN)
..K ^TMP("XMERR",$J)
;Test queue clearance
;I 'FODMN I (ECXLOGIC'=$$FISCAL^ECXUTL1(ECSD))!((ECXLOGIC>$$FISCAL^ECXUTL1(DT))!(ECXLOGIC=$$FISCAL^ECXUTL1(DT))) D Q:OUT
;.S OUT=0
;.K DIR
;.S DIR(0)="Y"
;.S DIR("A",1)="** This extract will be transmitted to the AAC test queue **"
;.S DIR("A")="Do you want to continue "
;.W !! D ^DIR
;.I 'Y S OUT=1 Q
;.S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",2)
;.S:ECXQUEUE="" ECXQUEUE="DMT"
S ZTSAVE("ECDA")="",ZTSAVE("ECXQUEUE")="",ZTSAVE("ECRE")=""
S ZTRTN="START^ECXTRANS",ZTIO=""
S ZTDESC="Transmission of extract # "_ECDA
W !! D ^%ZTLOAD
I $D(ZTSK) D
.W !,"Request queued as Task #",ZTSK,"."
.S ^ECX(727,ECDA,"Q")=ZTSK K ZTSK
.D PAUSE
Q
; entry point for task
START N DA,DIC,DIQ,DR,ECAR1,ECAR2,ECC1,ECC2,ECED,ECGPR,ECF,ECGRP,ECHEAD,ECINST
N ECMAX,ECMAXR,ECMSN,ECPACK,ECSIZ,ECVER,ECXDIC,I,J,EXDT
N STR,STRCNT,X,ECSD,ECXLOGIC
S:$P(^ECX(727,ECDA,0),U,3)'="Prosthetics" ECINST=$P(^ECX(728,1,0),U)
S:$P(^ECX(727,ECDA,0),U,3)="Prosthetics" ECINST=$P(^("DIV"),U)
S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I"))
S ECF=^ECX(727,ECDA,"FILE"),ECHEAD=^("HEAD"),ECGRP=^("GRP")
S X=^(0),ECPACK=$P(X,U,3),ECSD=$P(X,U,4),ECED=$P(X,U,5)
S X=$G(^("VER")),ECVER=$P(X,"^",1),ECXLOGIC=$P(X,"^",2)
S:'ECVER ECVER=1 S ECVER=$$RJ^XLFSTR(ECVER,3,0)
I ECXLOGIC="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD)
S ECXLOGIC=$$PAD^ECXUTL1(ECXLOGIC,5,"B"," ")
I ECPACK["(setup)" S ECXQUEUE="DMU"
K ^TMP($J)
S ECHD(1)=ECINST_ECHEAD_$$ECXYM^ECXUTL(ECED)_ECVER_ECXLOGIC
S ECMAX=130000,ECMAXR=250,ECLN=2,ECMSN=1,(ECRN,ECSIZ)=0,J=""
F S J=$O(^ECX(ECF,"AC",ECDA,J)) Q:('J) D
.M ECAR1=^ECX(ECF,J) S (ECAR2,ECC2)=1,(ECAR2(ECC2),ECC1)=""
.F S ECC1=$O(ECAR1(ECC1)) Q:ECC1="" D
..S:ECC1=0 ECAR1(ECC1)=$P(ECAR1(ECC1),"^",4,999)
..S ECAR2(ECC2)=ECAR2(ECC2)_$TR(ECAR1(ECC1),"~!"," ") I $L(ECAR2(ECC2))>ECMAXR D ;144,149 add ! to list of characters to be replaced
...F I=ECMAXR:-1:1 Q:$E(ECAR2(ECC2),I)="^"
...S (X,ECAR2)=ECAR2+1,ECAR2(X)=$E(ECAR2(ECC2),I+1,$L(ECAR2(ECC2)))
...S ECAR2(ECC2)=$E(ECAR2(ECC2),1,I),ECC2=X
.S ECAR2(ECC2)=ECAR2(ECC2)_"^~",ECRN=ECRN+1,X=""
.F S X=$O(ECAR2(X)) Q:X="" D
..S ^TMP($J,ECMSN,ECLN,0)=ECAR2(X),ECLN=ECLN+1,ECSIZ=ECSIZ+$L(ECAR2(X))
.K ECAR1,ECAR2
.I (ECSIZ>ECMAX),($O(^ECX(ECF,"AC",ECDA,J))) D
..S ECLN=2,ECMSN=ECMSN+1,ECSIZ=0
;quit if user stopped task
I $$S^%ZTLOAD D CLEAN Q
;generate mailman messages to aac
S ECXLNCNT=9,(ECXXMZ,STRCNT)=0,STR=""
F ECMS=1:1:ECMSN D
.D SEND(.ECXXMZ)
.S STR=STR_$$RJ^XLFSTR(ECXXMZ,18," "),STRCNT=STRCNT+1 I STRCNT=4 D
..S ^TMP($J,"LOC",ECXLNCNT,0)=STR,ECXLNCNT=ECXLNCNT+1
..S STR="",STRCNT=0
I STR]"" S ^TMP($J,"LOC",ECXLNCNT,0)=STR
;send msg to local dss grp
D SENDLOC,CLEAN
Q
;
SEND(ECXXMZ) ;send individual messages
N ECXDD,DA,DIC,DIE,DINUM,X,Y,Z,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,FODMN
S XMSUB=ECGRP_" "_ECINST_" - "_ECHEAD_" DSS EXTRACT, MESSAGE "_ECMS_" OF "_ECMSN ;149
S XMDUZ="DSS SYSTEM",^TMP($J,ECMS,1,0)=ECHD(1)
S XMY("XXX@Q-"_ECXQUEUE_".DOMAIN.EXT")=""
;Send extracts done at field offices to user instead of AAC
S FODMN=$$FODMN()
I FODMN D
.K XMY
.S XMY(DUZ)=""
S XMTEXT="^TMP($J,ECMS,"
D ^XMD
S ECXXMZ=XMZ
;store msg# in extract log
D FIELD^DID(727,301,"","SPECIFIER","ECXDD")
S DA(1)=ECDA,DIC(0)="L",DIC("P")=ECXDD("SPECIFIER")
S DIC="^ECX(727,"_DA(1)_",1,",X=XMZ,DINUM=X
K DD,DO D FILE^DICN
;Move message to DSSXMIT basket if sending from field office
I FODMN D
.N XMERR
.D MOVEMSG^XMXAPI(DUZ,,XMZ,"DSSXMIT",.X)
.K ^TMP("XMERR",$J)
Q
;
SENDLOC ; send message to mail group 'DSS-ECGRP'
S TIME=$P($$HTE^XLFDT($H),":",1,2)
S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
K XMY S XMY(DUZ)="",XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
S ^TMP($J,"LOC",1,0)="The DSS "_ECPACK_" ("_ECHEAD_") extract, #"_ECDA_","
S ^TMP($J,"LOC",2,0)="was "_ECRE_"transmitted on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_". "
S ^TMP($J,"LOC",3,0)=" "
S ^TMP($J,"LOC",4,0)="Maximum number of Bytes (characters) per message: 131,000 "
S ^TMP($J,"LOC",5,0)=" "
S ^TMP($J,"LOC",6,0)="A total of "_ECRN_" records were written."
S ^TMP($J,"LOC",7,0)="A total of "_ECMSN_" messages were sent."
S ^TMP($J,"LOC",8,0)=" Message numbers :"
S XMTEXT="^TMP($J,""LOC"","
D ^XMD
S ^ECX(727,ECDA,"TR")=DT
Q
;
CLEAN ;clean-up
S ZTREQ="@"
K ^TMP($J),^ECX(727,ECDA,"Q"),XMDUZ,XMTEXT,XMSUB,XMY,XMZ
K ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,ECXMAX,ECXMSG
D ^ECXKILL
I $$S^%ZTLOAD K ZTREQ S ZTSTOP=1
Q
;
PAUSE ;pause screen
S OUT=0
I $E(IOST)="C" D
.S SS=22-$Y F JJ=1:1:SS W !
.K DIR S DIR(0)="E" W ! D ^DIR K DIR
I 'Y S OUT=1
W !!
Q
;
FODMN(DOMAIN) ;Is domain a field office domain
;Input : DOMAIN - Domain name to check
; - Default value pulled from ^XMB("NETNAME")
;Output: 1 = Yes / 0 = No
;
N X,SUB,OUT
S DOMAIN=$G(DOMAIN)
S:(DOMAIN="") DOMAIN=$G(^XMB("NETNAME"))
S OUT=0
F X=1:1:$L(DOMAIN,".") D Q:OUT
.S SUB=$P(DOMAIN,".",X)
.I ($E(SUB,1,3)="FO-")!($E(SUB,1,4)="ISC-") S OUT=1
Q OUT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXTRANS 9598 printed Jan 18, 2025@02:55:19 Page 2
ECXTRANS ;ALB/GTS,JAP,BIR/DMA-Extract from Local Editing Files and Transmit ;3/29/17 15:15
+1 ;;3.0;DSS EXTRACTS;**2,9,12,8,13,14,23,24,33,49,54,75,71,144,149,166**;Dec 22, 1997;Build 24
EN ;entry point
+1 ;166
NEW ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,JJ,SS,OUT,DIR,DUOUT,ECXTREC
+2 NEW DTOUT,DIRUT,DIC,X,Y,ECXLOGIC,ECSD,FODMN
+3 SET ECXQUEUE=$PIECE($GET(^ECX(728,1,"QUEUE")),"^",1)
+4 IF ECXQUEUE'?1"DM"1U
Begin DoDot:1
+5 WRITE !,"You have not defined a proper transmission queue"
+6 WRITE !,"for entry number 1 in the DSS EXTRACTS file (#728)."
+7 WRITE !,"No transmission allowed."
+8 DO PAUSE
End DoDot:1
QUIT
+9 ;** check divisions for transmission
+10 SET ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
+11 IF 'ECCHK
Begin DoDot:1
+12 WRITE !,"You do not have any divisions defined in your user set up and cannot transmit."
+13 SET DIR(0)="FAO^1:1"
SET DIR("A")="Hit Return to continue."
DO ^DIR
KILL DIR,X,Y
End DoDot:1
QUIT
+14 WRITE !!,"Your user setup will only allow you to transmit extracts from the"
+15 WRITE !,"following divisions:",!
+16 SET ECDIVVR=""
+17 FOR
SET ECDIVVR=$ORDER(ECTMP(ECDIVVR))
if '(+ECDIVVR)
QUIT
Begin DoDot:1
+18 KILL ECXDIC
SET DA=ECDIVVR
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01"
+19 DO EN^DIQ1
WRITE !," ",$GET(ECXDIC(4,DA,.01,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:1
+20 WRITE !!,"If you can't select an extract, it is probably from another division.",!
+21 DO PAUSE
if OUT
QUIT
AGAIN SET ECRE=""
SET DIC="^ECX(727,"
SET DIC(0)="AEQM"
+1 NEW ECTYPE
+2 SET DIC("A")="Transmit which extract: "
+3 SET DIC("S")="I '$D(^ECX(727,+Y,""L"")),'$D(^ECX(727,+Y,""PURG"")),$D(ECTMP(+$P($G(^ECX(727,+Y,""DIV"")),U,1)))"
+4 ;166
SET DIC("W")="W:$G(DZ)[""?"" ?12,$E($P(^(0),U,2),4,5)_""-""_$E($P(^(0),U,2),6,7)_""-""_$E($P(^(0),U,2),2,3),?21,$P(^(0),U,3),?48,""Records Extracted: "",$S($P(^(0),U,6)'="""":$P(^(0),U,6),1:""Inc."")"
+5 DO ^DIC
+6 IF Y<0
WRITE !!
QUIT
+7 ;166
SET ECXTREC=$PIECE($GET(^ECX(727,+Y,0)),U,6)
+8 ;166
IF '+ECXTREC
Begin DoDot:1
+9 WRITE !!,$$REPEAT^XLFSTR("*",80)
+10 ;166
WRITE !,"* You may not transmit this extract because ",$SELECT(ECXTREC="":"it hasn't finished processing.",1:"it has 0 records."),?79,"*"
+11 ;166
WRITE !,"* Please check your selected extract to be sure it ",$SELECT(ECXTREC="":"has completed.",1:"has at least one record."),?79,"*"
+12 WRITE !,$$REPEAT^XLFSTR("*",80)
+13 ;166
QUIT
End DoDot:1
QUIT
+14 ;get data on extract
+15 SET DR="1;2;3;4;5;6;14;15"
SET (ECDA,DA)=+Y
SET DIQ(0)="IE"
SET DIQ="ECXDIQ"
DO EN^DIQ1
+16 IF ECXDIQ(727,ECDA,14,"I")=""
Begin DoDot:1
+17 SET ECXDIQ(727,ECDA,14,"I")=$$FISCAL^ECXUTL1(ECXDIQ(727,ECDA,3,"I"))
+18 SET ECXDIQ(727,ECDA,14,"E")=ECXDIQ(727,ECDA,14,"I")
End DoDot:1
+19 SET ECXLOGIC=ECXDIQ(727,ECDA,14,"I")
+20 SET ECSD=ECXDIQ(727,ECDA,3,"I")
+21 WRITE !!,ECXDIQ(727,ECDA,6,"E")_" Extract (#"_ECDA_")",?42,"Records: ",ECXDIQ(727,ECDA,5,"E")
+22 WRITE !,"Generated on: ",ECXDIQ(727,ECDA,1,"E"),?42,"Start date: ",ECXDIQ(727,ECDA,3,"E")
+23 WRITE !,"Division: ",$EXTRACT(ECXDIQ(727,ECDA,15,"E"),1,26),?42,"End date: ",ECXDIQ(727,ECDA,4,"E")
+24 SET X=$EXTRACT(ECXDIQ(727,ECDA,14,"I"),5)
SET X=$SELECT((X="")!(X=" "):"",1:"revision "_X_" of ")
+25 WRITE !!,"The data was extracted using "_X_"fiscal year "_$EXTRACT(ECXDIQ(727,ECDA,14,"I"),1,4)_" logic."
+26 WRITE !!,"MailMan transmission of the "_ECXDIQ(727,ECDA,2,"E")_" extract is set to a"
+27 WRITE !,"limit of 131,000 bytes per message. Each extract record ends with a ^~."
+28 IF $GET(^ECX(727,ECDA,"TR"))
SET ECX=^("TR")
Begin DoDot:1
+29 SET OUT=0
+30 WRITE !!,"This extract was transmitted on ",$TRANSLATE($$FMTE^XLFDT(ECX,"5DF")," ","0")
+31 KILL ECX
SET DIR(0)="Y"
SET DIR("A")="Do you want to retransmit "
DO ^DIR
KILL DIR
+32 IF 'Y
SET OUT=1
QUIT
+33 KILL ^ECX(727,ECDA,"TR")
+34 SET ECRE="re"
End DoDot:1
if OUT
QUIT
+35 SET ECTYPE=$PIECE(^ECX(727,ECDA,0),U,3)
SET ECIEN=+$ORDER(^ECX(727.1,"AC",ECTYPE,0))
+36 SET ECPIECE=$PIECE($GET(^ECX(727.1,ECIEN,0)),U,10)
+37 IF ECPIECE>0
IF $PIECE($GET(^ECX(728,1,7.1)),U,ECPIECE)]""
Begin DoDot:1
+38 DO MES^XPDUTL(" ")
+39 DO MES^XPDUTL("An "_ECTYPE_" Extract is currently running or scheduled to run.")
+40 DO MES^XPDUTL("Please wait until that job has completed before attempting")
+41 DO MES^XPDUTL("this transmission.")
+42 DO MES^XPDUTL(" ")
+43 DO PAUSE
End DoDot:1
QUIT
+44 SET ZTSK=$GET(^ECX(727,ECDA,"Q"))
+45 IF ZTSK
DO STAT^%ZTLOAD
IF ZTSK(0)
IF ZTSK(1)<3
Begin DoDot:1
+46 WRITE !!,"Task ",ZTSK," is already queued to transmit this extract."
+47 KILL ZTSK
+48 DO PAUSE
End DoDot:1
QUIT
+49 SET FODMN=$$FODMN()
+50 ;Field office reminder
+51 IF FODMN
Begin DoDot:1
+52 WRITE !
+53 WRITE !,"** This extract is being sent from a field office domain. **"
+54 WRITE !,"** Extract message(s) will only be delivered to you and **"
+55 WRITE !,"** will be placed into your 'DSSXMIT' mail basket. **"
+56 WRITE !
+57 ;Ensure user has a DSSXMIT mail basket
+58 NEW TMPARR
+59 DO LISTBSKT^XMXAPIB(DUZ,,,,"DSSXMIT","TMPARR")
+60 IF '$DATA(TMPARR("XMLIST","BSKT","DSSXMIT"))
Begin DoDot:2
+61 ;Create DSSXMIT basket
+62 NEW IEN,XMERR
+63 DO CRE8BSKT^XMXAPIB(DUZ,"DSSXMIT",.IEN)
+64 KILL ^TMP("XMERR",$JOB)
End DoDot:2
End DoDot:1
+65 ;Test queue clearance
+66 ;I 'FODMN I (ECXLOGIC'=$$FISCAL^ECXUTL1(ECSD))!((ECXLOGIC>$$FISCAL^ECXUTL1(DT))!(ECXLOGIC=$$FISCAL^ECXUTL1(DT))) D Q:OUT
+67 ;.S OUT=0
+68 ;.K DIR
+69 ;.S DIR(0)="Y"
+70 ;.S DIR("A",1)="** This extract will be transmitted to the AAC test queue **"
+71 ;.S DIR("A")="Do you want to continue "
+72 ;.W !! D ^DIR
+73 ;.I 'Y S OUT=1 Q
+74 ;.S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",2)
+75 ;.S:ECXQUEUE="" ECXQUEUE="DMT"
+76 SET ZTSAVE("ECDA")=""
SET ZTSAVE("ECXQUEUE")=""
SET ZTSAVE("ECRE")=""
+77 SET ZTRTN="START^ECXTRANS"
SET ZTIO=""
+78 SET ZTDESC="Transmission of extract # "_ECDA
+79 WRITE !!
DO ^%ZTLOAD
+80 IF $DATA(ZTSK)
Begin DoDot:1
+81 WRITE !,"Request queued as Task #",ZTSK,"."
+82 SET ^ECX(727,ECDA,"Q")=ZTSK
KILL ZTSK
+83 DO PAUSE
End DoDot:1
+84 QUIT
+85 ; entry point for task
START NEW DA,DIC,DIQ,DR,ECAR1,ECAR2,ECC1,ECC2,ECED,ECGPR,ECF,ECGRP,ECHEAD,ECINST
+1 NEW ECMAX,ECMAXR,ECMSN,ECPACK,ECSIZ,ECVER,ECXDIC,I,J,EXDT
+2 NEW STR,STRCNT,X,ECSD,ECXLOGIC
+3 if $PIECE(^ECX(727,ECDA,0),U,3)'="Prosthetics"
SET ECINST=$PIECE(^ECX(728,1,0),U)
+4 if $PIECE(^ECX(727,ECDA,0),U,3)="Prosthetics"
SET ECINST=$PIECE(^("DIV"),U)
+5 SET DA=ECINST
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+6 DO EN^DIQ1
SET ECINST=$GET(ECXDIC(4,DA,99,"I"))
+7 SET ECF=^ECX(727,ECDA,"FILE")
SET ECHEAD=^("HEAD")
SET ECGRP=^("GRP")
+8 SET X=^(0)
SET ECPACK=$PIECE(X,U,3)
SET ECSD=$PIECE(X,U,4)
SET ECED=$PIECE(X,U,5)
+9 SET X=$GET(^("VER"))
SET ECVER=$PIECE(X,"^",1)
SET ECXLOGIC=$PIECE(X,"^",2)
+10 if 'ECVER
SET ECVER=1
SET ECVER=$$RJ^XLFSTR(ECVER,3,0)
+11 IF ECXLOGIC=""
SET ECXLOGIC=$$FISCAL^ECXUTL1(ECSD)
+12 SET ECXLOGIC=$$PAD^ECXUTL1(ECXLOGIC,5,"B"," ")
+13 IF ECPACK["(setup)"
SET ECXQUEUE="DMU"
+14 KILL ^TMP($JOB)
+15 SET ECHD(1)=ECINST_ECHEAD_$$ECXYM^ECXUTL(ECED)_ECVER_ECXLOGIC
+16 SET ECMAX=130000
SET ECMAXR=250
SET ECLN=2
SET ECMSN=1
SET (ECRN,ECSIZ)=0
SET J=""
+17 FOR
SET J=$ORDER(^ECX(ECF,"AC",ECDA,J))
if ('J)
QUIT
Begin DoDot:1
+18 MERGE ECAR1=^ECX(ECF,J)
SET (ECAR2,ECC2)=1
SET (ECAR2(ECC2),ECC1)=""
+19 FOR
SET ECC1=$ORDER(ECAR1(ECC1))
if ECC1=""
QUIT
Begin DoDot:2
+20 if ECC1=0
SET ECAR1(ECC1)=$PIECE(ECAR1(ECC1),"^",4,999)
+21 ;144,149 add ! to list of characters to be replaced
SET ECAR2(ECC2)=ECAR2(ECC2)_$TRANSLATE(ECAR1(ECC1),"~!"," ")
IF $LENGTH(ECAR2(ECC2))>ECMAXR
Begin DoDot:3
+22 FOR I=ECMAXR:-1:1
if $EXTRACT(ECAR2(ECC2),I)="^"
QUIT
+23 SET (X,ECAR2)=ECAR2+1
SET ECAR2(X)=$EXTRACT(ECAR2(ECC2),I+1,$LENGTH(ECAR2(ECC2)))
+24 SET ECAR2(ECC2)=$EXTRACT(ECAR2(ECC2),1,I)
SET ECC2=X
End DoDot:3
End DoDot:2
+25 SET ECAR2(ECC2)=ECAR2(ECC2)_"^~"
SET ECRN=ECRN+1
SET X=""
+26 FOR
SET X=$ORDER(ECAR2(X))
if X=""
QUIT
Begin DoDot:2
+27 SET ^TMP($JOB,ECMSN,ECLN,0)=ECAR2(X)
SET ECLN=ECLN+1
SET ECSIZ=ECSIZ+$LENGTH(ECAR2(X))
End DoDot:2
+28 KILL ECAR1,ECAR2
+29 IF (ECSIZ>ECMAX)
IF ($ORDER(^ECX(ECF,"AC",ECDA,J)))
Begin DoDot:2
+30 SET ECLN=2
SET ECMSN=ECMSN+1
SET ECSIZ=0
End DoDot:2
End DoDot:1
+31 ;quit if user stopped task
+32 IF $$S^%ZTLOAD
DO CLEAN
QUIT
+33 ;generate mailman messages to aac
+34 SET ECXLNCNT=9
SET (ECXXMZ,STRCNT)=0
SET STR=""
+35 FOR ECMS=1:1:ECMSN
Begin DoDot:1
+36 DO SEND(.ECXXMZ)
+37 SET STR=STR_$$RJ^XLFSTR(ECXXMZ,18," ")
SET STRCNT=STRCNT+1
IF STRCNT=4
Begin DoDot:2
+38 SET ^TMP($JOB,"LOC",ECXLNCNT,0)=STR
SET ECXLNCNT=ECXLNCNT+1
+39 SET STR=""
SET STRCNT=0
End DoDot:2
End DoDot:1
+40 IF STR]""
SET ^TMP($JOB,"LOC",ECXLNCNT,0)=STR
+41 ;send msg to local dss grp
+42 DO SENDLOC
DO CLEAN
+43 QUIT
+44 ;
SEND(ECXXMZ) ;send individual messages
+1 NEW ECXDD,DA,DIC,DIE,DINUM,X,Y,Z,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,FODMN
+2 ;149
SET XMSUB=ECGRP_" "_ECINST_" - "_ECHEAD_" DSS EXTRACT, MESSAGE "_ECMS_" OF "_ECMSN
+3 SET XMDUZ="DSS SYSTEM"
SET ^TMP($JOB,ECMS,1,0)=ECHD(1)
+4 SET XMY("XXX@Q-"_ECXQUEUE_".DOMAIN.EXT")=""
+5 ;Send extracts done at field offices to user instead of AAC
+6 SET FODMN=$$FODMN()
+7 IF FODMN
Begin DoDot:1
+8 KILL XMY
+9 SET XMY(DUZ)=""
End DoDot:1
+10 SET XMTEXT="^TMP($J,ECMS,"
+11 DO ^XMD
+12 SET ECXXMZ=XMZ
+13 ;store msg# in extract log
+14 DO FIELD^DID(727,301,"","SPECIFIER","ECXDD")
+15 SET DA(1)=ECDA
SET DIC(0)="L"
SET DIC("P")=ECXDD("SPECIFIER")
+16 SET DIC="^ECX(727,"_DA(1)_",1,"
SET X=XMZ
SET DINUM=X
+17 KILL DD,DO
DO FILE^DICN
+18 ;Move message to DSSXMIT basket if sending from field office
+19 IF FODMN
Begin DoDot:1
+20 NEW XMERR
+21 DO MOVEMSG^XMXAPI(DUZ,,XMZ,"DSSXMIT",.X)
+22 KILL ^TMP("XMERR",$JOB)
End DoDot:1
+23 QUIT
+24 ;
SENDLOC ; send message to mail group 'DSS-ECGRP'
+1 SET TIME=$PIECE($$HTE^XLFDT($HOROLOG),":",1,2)
+2 SET XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS"
SET XMDUZ="DSS SYSTEM"
+3 KILL XMY
SET XMY(DUZ)=""
SET XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
+4 SET ^TMP($JOB,"LOC",1,0)="The DSS "_ECPACK_" ("_ECHEAD_") extract, #"_ECDA_","
+5 SET ^TMP($JOB,"LOC",2,0)="was "_ECRE_"transmitted on "_$PIECE(TIME,"@")_" at "_$PIECE(TIME,"@",2)_". "
+6 SET ^TMP($JOB,"LOC",3,0)=" "
+7 SET ^TMP($JOB,"LOC",4,0)="Maximum number of Bytes (characters) per message: 131,000 "
+8 SET ^TMP($JOB,"LOC",5,0)=" "
+9 SET ^TMP($JOB,"LOC",6,0)="A total of "_ECRN_" records were written."
+10 SET ^TMP($JOB,"LOC",7,0)="A total of "_ECMSN_" messages were sent."
+11 SET ^TMP($JOB,"LOC",8,0)=" Message numbers :"
+12 SET XMTEXT="^TMP($J,""LOC"","
+13 DO ^XMD
+14 SET ^ECX(727,ECDA,"TR")=DT
+15 QUIT
+16 ;
CLEAN ;clean-up
+1 SET ZTREQ="@"
+2 KILL ^TMP($JOB),^ECX(727,ECDA,"Q"),XMDUZ,XMTEXT,XMSUB,XMY,XMZ
+3 KILL ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,ECXMAX,ECXMSG
+4 DO ^ECXKILL
+5 IF $$S^%ZTLOAD
KILL ZTREQ
SET ZTSTOP=1
+6 QUIT
+7 ;
PAUSE ;pause screen
+1 SET OUT=0
+2 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 KILL DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+5 IF 'Y
SET OUT=1
+6 WRITE !!
+7 QUIT
+8 ;
FODMN(DOMAIN) ;Is domain a field office domain
+1 ;Input : DOMAIN - Domain name to check
+2 ; - Default value pulled from ^XMB("NETNAME")
+3 ;Output: 1 = Yes / 0 = No
+4 ;
+5 NEW X,SUB,OUT
+6 SET DOMAIN=$GET(DOMAIN)
+7 if (DOMAIN="")
SET DOMAIN=$GET(^XMB("NETNAME"))
+8 SET OUT=0
+9 FOR X=1:1:$LENGTH(DOMAIN,".")
Begin DoDot:1
+10 SET SUB=$PIECE(DOMAIN,".",X)
+11 IF ($EXTRACT(SUB,1,3)="FO-")!($EXTRACT(SUB,1,4)="ISC-")
SET OUT=1
End DoDot:1
if OUT
QUIT
+12 QUIT OUT
