GECSTRAN ;WISC/RFJ/KLD-transmit a batch ;01 Nov 93
;;2.0;GCS;**13,15,20**;MAR 14, 1995
N %,%X,CODE,D,DOMAIN,DA,GECS,GECSBADA,GECSBATC,GECSCODE,GECSDICS,GECSLINE,GECSMAX,GECSMSG,GECSXMY,GECSSYDA,GECSTOTL,GECSXMZ,PRIORITY,X,Y
D ^GECSSITE Q:'$G(GECS("SITE"))
D BATNOFMS^GECSUSEL Q:'$G(GECS("BATDA"))
S GECS("SITECOM")=GECS("SITE")_GECS("SITE1")
S GECSDICS="S %=^(0) I $S($P(%,""-"",1)=GECS(""SITECOM"")&($P(^(0),U,6)=GECS(""BATDA"")):1,1:0)"
W ! S GECSBADA=$$BATCHSEL^GECSUSEL(GECSDICS) Q:'GECSBADA
S GECSBATC=$P($G(^GECS(2101.3,GECSBADA,0)),"^") I GECSBATC="" W !,"CANNOT FIND BATCH NUMBER IN FILE 2101.3." Q
;
; build receiving users for mail messages
K GECSXMY
S %=0 F S %=$O(^GECS(2101.1,GECS("BATDA"),2,%)) Q:'% S D=$G(^(%,0)) I $P(D,"^",3)=1 D
. S DOMAIN=$P($G(^DIC(4.2,+$P(D,"^",2),0)),"^") I DOMAIN'="" S DOMAIN="@"_DOMAIN
. S GECSXMY($P(D,"^")_DOMAIN)=""
I '$D(GECSXMY) W !,"RECEIVING USERS FOR THIS BATCH TYPE HAVE NOT BEEN ENTERED." Q
W !!,"Transmission will be to the following:"
S %="" F S %=$O(GECSXMY(%)) Q:%="" W !?5,%
;
;
RETRY ; if locked, come here to retry transmission
S XP="ARE YOU READY TO TRANSMIT THE CODE SHEETS",XH="Enter YES to transmit the code sheets, NO or ^ to exit." W ! I $$YN^GECSUTIL(2)'=1 Q
;
; check lock and lock system
S GECSSYDA=$$LOCKSYS^GECSULOC(GECS("SITE")_"-"_GECS("SYSID")_"-TRANSMIT")
I 'GECSSYDA W !!,"ANOTHER USER IS TRANSMITTING THE CODE SHEETS, TRY AGAIN IN A MINUTE" G RETRY
;
; check to see if batch has been transmitted, if so quit
I $P($G(^GECS(2101.3,GECSBADA,0)),"^",3)'="B" D UNLOCK^GECSULOC(GECSSYDA) Q
;
; get maximum number of code sheets per message
S GECSMAX=$P($G(^GECS(2101.1,GECS("BATDA"),0)),"^",3) I 'GECSMAX S GECSMAX=999999999
;
; build priority list
K ^TMP($J,"GECSTRAN")
S DA=0 F S DA=$O(^GECS(2100,"AB",GECSBATC,DA)) Q:'DA I $O(^GECS(2100,DA,"CODE",0)) S D=$G(^GECS(2100,DA,"TRANS")) I D'="" D
. S PRIORITY=$P(D,"^",10) S:'PRIORITY PRIORITY=3
. S ^TMP($J,"GECSTRAN",PRIORITY,DA)=""
;
; build messages
K ^TMP($J,"GECSTRAN MM")
S (GECSMSG,GECSLINE)=1
S PRIORITY=0 F S PRIORITY=$O(^TMP($J,"GECSTRAN",PRIORITY)) Q:'PRIORITY S (DA,GECSCODE)=0 F S DA=$O(^TMP($J,"GECSTRAN",PRIORITY,DA)) Q:'DA D
. ;
. ; umark code sheet for transmission
. S $P(^GECS(2100,DA,"TRANS"),"^",2)="" K ^GECS(2100,"AE","Y",DA)
. ;
. S GECSCODE=GECSCODE+1
. I GECSCODE>GECSMAX S GECSMSG=GECSMSG+1,(GECSCODE,GECSLINE)=1
. ;
. ; special code to create calm header for fee code sheets 994.xx
. I $P(GECSBATC,"-",2)="FEN",GECSLINE=1 D
. . S %=$P(GECSBATC,"-",4)
. . N Y,X
. . S Y=DT D DD^%DT
. . S ^TMP($J,"GECSTRAN MM",GECSMSG,GECSLINE,0)=$E($G(^GECS(2100,DA,"CODE",1,0)),1,3)_"."_$P(GECSBATC,"-")_".999.01."_$E(DT,4,7)_$E(DT,2,3)_".06"_$E("0000",$L(%)+1,4)_%_".$",GECSLINE=GECSLINE+1
. S %=0 F S %=$O(^GECS(2100,DA,"CODE",%)) Q:'% S CODE=$G(^(%,0)) I CODE'="" D
. . S ^TMP($J,"GECSTRAN MM",GECSMSG,GECSLINE,0)=CODE,GECSLINE=GECSLINE+1
;
S GECSTOTL=GECSMSG
; transmit
W !
S GECSMSG=0 F S GECSMSG=$O(^TMP($J,"GECSTRAN MM",GECSMSG)) Q:'GECSMSG D
. ;create mailman message
. W !,"MESSAGE NUMBER: "
. S GECSXMZ=$$MAILMSG(GECS("BATCH"),GECSBATC,.GECSXMY,GECSMSG,GECSTOTL)
. W GECSXMZ
. I 'GECSXMZ Q
. ;
. ; set message number in batch
. D SETMSG(GECSBADA,GECSXMZ)
;
; update file 2101.3
D UPDATE(GECSBADA)
Q
;
;
MAILMSG(BATCHNME,BATCHNUM,RECUSERS,MSGNUMBR,TOTALMSG) ; create mailman msg
; batchnme=name of batch
; batchnum=batch number
; recusers()=array of receiving users (same as xmy)
; msgnumbr=this message number
; totalmsg=total number of messages to transmit in all
; returns xmz message number
N %,DIC,XCNP,XMDISPI,XMDUZ,XMTEXT,XMY,XMZ
;
; build receiving queue and user array
S %="" F S %=$O(RECUSERS(%)) Q:%="" S XMY(%)=""
S XMY(DUZ)="",XMDUZ=DUZ
;
S XMTEXT="^TMP($J,""GECSTRAN MM"","_MSGNUMBR_",",XMSUB="GECS "_BATCHNME_" # "_BATCHNUM_" (MSG "_MSGNUMBR_" OF "_TOTALMSG_")"
K XMZ D ^XMD
Q $G(XMZ)
;
;
UPDATE(DA) ; update file 2101.3 batch as being transmitted
N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y
S (DIC,DIE)="^GECS(2101.3,",DR=".5///T;4///T;5////"_DUZ D ^DIE
Q
;
;
SETMSG(DA,XMZ) ; set message number in batch
N %,D0,DD,DIC,DLAYGO,X,Y
I '$D(^GECS(2101.3,DA,0)) Q
S:'$D(^GECS(2101.3,DA,2,0)) ^(0)="^2101.32^^"
S DIC="^GECS(2101.3,"_DA_",2,",DIC(0)="L",DLAYGO=2101.3,X=XMZ D FILE^DICN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGECSTRAN 4596 printed Dec 13, 2024@01:56:33 Page 2
GECSTRAN ;WISC/RFJ/KLD-transmit a batch ;01 Nov 93
+1 ;;2.0;GCS;**13,15,20**;MAR 14, 1995
+2 NEW %,%X,CODE,D,DOMAIN,DA,GECS,GECSBADA,GECSBATC,GECSCODE,GECSDICS,GECSLINE,GECSMAX,GECSMSG,GECSXMY,GECSSYDA,GECSTOTL,GECSXMZ,PRIORITY,X,Y
+3 DO ^GECSSITE
if '$GET(GECS("SITE"))
QUIT
+4 DO BATNOFMS^GECSUSEL
if '$GET(GECS("BATDA"))
QUIT
+5 SET GECS("SITECOM")=GECS("SITE")_GECS("SITE1")
+6 SET GECSDICS="S %=^(0) I $S($P(%,""-"",1)=GECS(""SITECOM"")&($P(^(0),U,6)=GECS(""BATDA"")):1,1:0)"
+7 WRITE !
SET GECSBADA=$$BATCHSEL^GECSUSEL(GECSDICS)
if 'GECSBADA
QUIT
+8 SET GECSBATC=$PIECE($GET(^GECS(2101.3,GECSBADA,0)),"^")
IF GECSBATC=""
WRITE !,"CANNOT FIND BATCH NUMBER IN FILE 2101.3."
QUIT
+9 ;
+10 ; build receiving users for mail messages
+11 KILL GECSXMY
+12 SET %=0
FOR
SET %=$ORDER(^GECS(2101.1,GECS("BATDA"),2,%))
if '%
QUIT
SET D=$GET(^(%,0))
IF $PIECE(D,"^",3)=1
Begin DoDot:1
+13 SET DOMAIN=$PIECE($GET(^DIC(4.2,+$PIECE(D,"^",2),0)),"^")
IF DOMAIN'=""
SET DOMAIN="@"_DOMAIN
+14 SET GECSXMY($PIECE(D,"^")_DOMAIN)=""
End DoDot:1
+15 IF '$DATA(GECSXMY)
WRITE !,"RECEIVING USERS FOR THIS BATCH TYPE HAVE NOT BEEN ENTERED."
QUIT
+16 WRITE !!,"Transmission will be to the following:"
+17 SET %=""
FOR
SET %=$ORDER(GECSXMY(%))
if %=""
QUIT
WRITE !?5,%
+18 ;
+19 ;
RETRY ; if locked, come here to retry transmission
+1 SET XP="ARE YOU READY TO TRANSMIT THE CODE SHEETS"
SET XH="Enter YES to transmit the code sheets, NO or ^ to exit."
WRITE !
IF $$YN^GECSUTIL(2)'=1
QUIT
+2 ;
+3 ; check lock and lock system
+4 SET GECSSYDA=$$LOCKSYS^GECSULOC(GECS("SITE")_"-"_GECS("SYSID")_"-TRANSMIT")
+5 IF 'GECSSYDA
WRITE !!,"ANOTHER USER IS TRANSMITTING THE CODE SHEETS, TRY AGAIN IN A MINUTE"
GOTO RETRY
+6 ;
+7 ; check to see if batch has been transmitted, if so quit
+8 IF $PIECE($GET(^GECS(2101.3,GECSBADA,0)),"^",3)'="B"
DO UNLOCK^GECSULOC(GECSSYDA)
QUIT
+9 ;
+10 ; get maximum number of code sheets per message
+11 SET GECSMAX=$PIECE($GET(^GECS(2101.1,GECS("BATDA"),0)),"^",3)
IF 'GECSMAX
SET GECSMAX=999999999
+12 ;
+13 ; build priority list
+14 KILL ^TMP($JOB,"GECSTRAN")
+15 SET DA=0
FOR
SET DA=$ORDER(^GECS(2100,"AB",GECSBATC,DA))
if 'DA
QUIT
IF $ORDER(^GECS(2100,DA,"CODE",0))
SET D=$GET(^GECS(2100,DA,"TRANS"))
IF D'=""
Begin DoDot:1
+16 SET PRIORITY=$PIECE(D,"^",10)
if 'PRIORITY
SET PRIORITY=3
+17 SET ^TMP($JOB,"GECSTRAN",PRIORITY,DA)=""
End DoDot:1
+18 ;
+19 ; build messages
+20 KILL ^TMP($JOB,"GECSTRAN MM")
+21 SET (GECSMSG,GECSLINE)=1
+22 SET PRIORITY=0
FOR
SET PRIORITY=$ORDER(^TMP($JOB,"GECSTRAN",PRIORITY))
if 'PRIORITY
QUIT
SET (DA,GECSCODE)=0
FOR
SET DA=$ORDER(^TMP($JOB,"GECSTRAN",PRIORITY,DA))
if 'DA
QUIT
Begin DoDot:1
+23 ;
+24 ; umark code sheet for transmission
+25 SET $PIECE(^GECS(2100,DA,"TRANS"),"^",2)=""
KILL ^GECS(2100,"AE","Y",DA)
+26 ;
+27 SET GECSCODE=GECSCODE+1
+28 IF GECSCODE>GECSMAX
SET GECSMSG=GECSMSG+1
SET (GECSCODE,GECSLINE)=1
+29 ;
+30 ; special code to create calm header for fee code sheets 994.xx
+31 IF $PIECE(GECSBATC,"-",2)="FEN"
IF GECSLINE=1
Begin DoDot:2
+32 SET %=$PIECE(GECSBATC,"-",4)
+33 NEW Y,X
+34 SET Y=DT
DO DD^%DT
+35 SET ^TMP($JOB,"GECSTRAN MM",GECSMSG,GECSLINE,0)=$EXTRACT($GET(^GECS(2100,DA,"CODE",1,0)),1,3)_"."_$PIECE(GECSBATC,"-")_".999.01."_$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)_".06"_$EXTRACT("0000",$LENGTH(%)+1,4)_%_".$"
SET GECSLINE=GECSLINE+1
End DoDot:2
+36 SET %=0
FOR
SET %=$ORDER(^GECS(2100,DA,"CODE",%))
if '%
QUIT
SET CODE=$GET(^(%,0))
IF CODE'=""
Begin DoDot:2
+37 SET ^TMP($JOB,"GECSTRAN MM",GECSMSG,GECSLINE,0)=CODE
SET GECSLINE=GECSLINE+1
End DoDot:2
End DoDot:1
+38 ;
+39 SET GECSTOTL=GECSMSG
+40 ; transmit
+41 WRITE !
+42 SET GECSMSG=0
FOR
SET GECSMSG=$ORDER(^TMP($JOB,"GECSTRAN MM",GECSMSG))
if 'GECSMSG
QUIT
Begin DoDot:1
+43 ;create mailman message
+44 WRITE !,"MESSAGE NUMBER: "
+45 SET GECSXMZ=$$MAILMSG(GECS("BATCH"),GECSBATC,.GECSXMY,GECSMSG,GECSTOTL)
+46 WRITE GECSXMZ
+47 IF 'GECSXMZ
QUIT
+48 ;
+49 ; set message number in batch
+50 DO SETMSG(GECSBADA,GECSXMZ)
End DoDot:1
+51 ;
+52 ; update file 2101.3
+53 DO UPDATE(GECSBADA)
+54 QUIT
+55 ;
+56 ;
MAILMSG(BATCHNME,BATCHNUM,RECUSERS,MSGNUMBR,TOTALMSG) ; create mailman msg
+1 ; batchnme=name of batch
+2 ; batchnum=batch number
+3 ; recusers()=array of receiving users (same as xmy)
+4 ; msgnumbr=this message number
+5 ; totalmsg=total number of messages to transmit in all
+6 ; returns xmz message number
+7 NEW %,DIC,XCNP,XMDISPI,XMDUZ,XMTEXT,XMY,XMZ
+8 ;
+9 ; build receiving queue and user array
+10 SET %=""
FOR
SET %=$ORDER(RECUSERS(%))
if %=""
QUIT
SET XMY(%)=""
+11 SET XMY(DUZ)=""
SET XMDUZ=DUZ
+12 ;
+13 SET XMTEXT="^TMP($J,""GECSTRAN MM"","_MSGNUMBR_","
SET XMSUB="GECS "_BATCHNME_" # "_BATCHNUM_" (MSG "_MSGNUMBR_" OF "_TOTALMSG_")"
+14 KILL XMZ
DO ^XMD
+15 QUIT $GET(XMZ)
+16 ;
+17 ;
UPDATE(DA) ; update file 2101.3 batch as being transmitted
+1 NEW %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y
+2 SET (DIC,DIE)="^GECS(2101.3,"
SET DR=".5///T;4///T;5////"_DUZ
DO ^DIE
+3 QUIT
+4 ;
+5 ;
SETMSG(DA,XMZ) ; set message number in batch
+1 NEW %,D0,DD,DIC,DLAYGO,X,Y
+2 IF '$DATA(^GECS(2101.3,DA,0))
QUIT
+3 if '$DATA(^GECS(2101.3,DA,2,0))
SET ^(0)="^2101.32^^"
+4 SET DIC="^GECS(2101.3,"_DA_",2,"
SET DIC(0)="L"
SET DLAYGO=2101.3
SET X=XMZ
DO FILE^DICN
+5 QUIT
