- 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 Jan 18, 2025@02:57:45 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