PRCFACBT ;WISC/CTB/CLH-BACKGROUND RELEASE OF CODE SHEETS ;5/18/93 08:37
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;PRCF("BTCH") - required and equal to batch number
;PRCFASYS - required and equal to the system identifier
;PRC(* - required and equal to standard system-wide variables returned
; in ^PRCFSITE
N B,PBATN,PBAT,DIE,BY,FR,TO,FLDS,PRCFKEY,PRCFRT,X,DIC,%,PBAT,PTRN,PTR,ADD,%I,%Y,DA,ISYS,I,L,N,PRCOUT,PTYP,X9,XCNP,XMDUZ,XMHOLD,XMZ,Y,ZN,ZTREQ,ZTSK
D NOW^%DTC S PRCFKEY=%_"-"_DUZ
S PRCFRT=0,X=PRCF("BTCH")
S DIC=421.2,DIC(0)="XMN",DIC("S")="S XXX=^(0) I $P(XXX,U,4)="""",$P(XXX,U,3)=""B"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
D ^DIC K DIC,XXX I Y<0 S PRCOUT=1 G OUT
S PBAT=$P(Y,U,2),PBATN=+Y S $P(^PRCF(421.2,PBATN,0),"^",15)=PRCFKEY,^PRCF(421.2,"AD",PRCFKEY,PBATN)=""
I '$D(^PRCF(421.2,"AD",PRCFKEY)) S PRCOUT=1 G OUT
;
N PBATN,PBAT,DIE,BY,FR,TO,FLDS
K ^TMP("PRCFBTCH",$J)
D DT^DICRW
F S PBATN=$O(^PRCF(421.2,"AD",PRCFKEY,0)) Q:+PBATN=0 S PBAT=$P(^PRCF(421.2,PBATN,0),"^") D K ^PRCF(421.2,"AD",PRCFKEY,PBATN) S $P(^PRCF(421.2,PBATN,0),"^",15)="",I=1
.I $D(^PRCF(423,"AD",PBAT)) S N=0 F S N=$O(^PRCF(423,"AD",PBAT,N)) Q:N'=+N S ^PRCF(423,"AK",PRCFKEY,N)="",$P(^PRCF(423,N,"TRANS"),"^",11)=PRCFKEY D:"ISMPRC"[PRCFASYS ^PRCFAIS D:"FEEFENLOGCAPIRS"[PRCFASYS TX2^PRCFAIS Q
.I $G(PRCOUT)]"",PRCOUT=1 Q
.Q:+PBATN'>0
.S DA=PBATN
.S:$G(P)]"" PX=P
.D NOW^%DTC
.S XDT=%
.S X1=$P(PRC("PER"),"^",2)
.S $P(^PRCF(421.2,DA,0),"^",4+PRCFRT)=XDT
.K XDT
.S MESSAGE=""
.I PRCFRT=0 D ENCODE^PRCFAES1(DA,DUZ,.MESSAGE)
.I PRCFRT=3 D ENCODE^PRCFAES2(DA,DUZ,.MESSAGE)
.K MESSAGE
.K P I $D(PX) S P=PX K PX Q
.Q
G:$G(PRCOUT) OUT
K ^TMP("PRCFBTCH",$J)
S ZTIO=$O(^PRC(411,PRC("SITE"),2,"AC","S","")),ZTSAVE("*")="",ZTRTN="DQ^PRCFACBT",ZTDESC="Transmit Code sheets",ZTDTH=$H D ^%ZTLOAD K IO("Q")
Q
DQ ;Entry point to transmit code sheets in background
S IOP=IO,DIC="^PRCF(423,",L=0,BY="[PRCFA BATCH TRANSMIT SORT]",FLDS="[PRCFA BACKGROUND TRANSMIT]",(FR,TO)=PRCFKEY,PRCFX="",DIOEND="W @IOF"
D EN1^DIP
;this section will take the globals created during the print and
;give them to mailman for transmission
S N=0 F S N=$O(^TMP("PRCFBTCH",$J,N)) Q:N'=+N S PTYP=$O(^PRCF(423.9,"AC",N,0)) Q:PTYP="" I $P(^PRCF(423.9,PTYP,0),"^",4)["Y" D
.S M=0 F S M=$O(^TMP("PRCFBTCH",$J,N,M)) Q:M="" D
..Q:'$D(^PRCF(423.9,PTYP,0)) D:"3,1,4,2,9,10,12"[N
...;TAKE 4th '-' PIECE OF BATCH NUMBER AND MAKE IT INTO MMCCC
...; WHERE MM = MONTH
...; CCC = LAST 3 DIGITS OF COUNTER VALUE
...S SHRINK=$G(^TMP("PRCFBTCH",$J,N,M,1,0)) Q:SHRINK="" I $P(SHRINK,".",3)=999 S SHRINK1=$P(SHRINK,".",6),SHRINK2=$E(SHRINK1,1,2)_$E(SHRINK1,$L(SHRINK1)-2,99),$P(SHRINK,".",6)=SHRINK2,^TMP("PRCFBTCH",$J,N,M,1,0)=SHRINK
...K SHRINK,SHRINK1,SHRINK2 Q
..S M1=$P(M,"-",4),M2=$E(M1,1,2)_$E(M1,$L(M1)-2,99),MM=$P(M,"-",1,3)_"-"_M2 K M1,M2 D
...K ADD S ADD=$P($G(^PRCF(423.9,PTYP,0)),U,2) S:ADD]"" XMY(ADD)="" S:$G(PRCFA("EDI"))]"" XMY(PRCFA("EDI"))="" S:$G(PRCFA("ISM"))]"" XMY(PRCFA("ISM"))="" K PRCFA("EDI"),PRCFA("ISM")
...K ADD
...I $D(^PRCF(423.9,PTYP,1,0)) D
....S L=0 F S L=$O(^PRCF(423.9,PTYP,1,L)) Q:L'=+L I $D(^PRCF(423.9,PTYP,1,L,0)) S ADD=$P(^(0),"^",1) S XMY(ADD)=""
....Q
..S XMDUZ=DUZ,XMSUB="ISMS/EDI BATCH "_MM,XMTEXT="^TMP(""PRCFBTCH"","_$J_","_N_","""_M_""","
..D XMD
..I $D(M),M["" S X=$O(^PRCF(421.2,"B",M,0)) Q:X=""
..S:$D(^PRCF(421.2,X,0)) $P(^(0),"^",12)=XMZ,^PRCF(421.2,"D",XMZ,X)=""
..Q
.Q
S N=0 F S N=$O(^PRCF(423,"AK",PRCFKEY,N)) Q:'N S $P(^PRCF(423,N,"TRANS"),"^",11)=""
K %,%DT,%I,BATCH,BATTYPE,DP,I,J,K,L,M,N,PRCFX,PTYP,X,Y,Z1,Z2
OUT S ZTREQ="@" K PRCF("BTCH"),^TMP("PRCFBTCH",$J),^PRCF(423,"AK",PRCFKEY),PRCFKEY
Q
;
XMD N I,J,K,L,M,N
D ^XMD
S:$D(PRCOPODA) $P(^PRC(442,PRCOPODA,12),U,10)=XMZ
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACBT 3890 printed Nov 22, 2024@17:12:06 Page 2
PRCFACBT ;WISC/CTB/CLH-BACKGROUND RELEASE OF CODE SHEETS ;5/18/93 08:37
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;PRCF("BTCH") - required and equal to batch number
+3 ;PRCFASYS - required and equal to the system identifier
+4 ;PRC(* - required and equal to standard system-wide variables returned
+5 ; in ^PRCFSITE
+6 NEW B,PBATN,PBAT,DIE,BY,FR,TO,FLDS,PRCFKEY,PRCFRT,X,DIC,%,PBAT,PTRN,PTR,ADD,%I,%Y,DA,ISYS,I,L,N,PRCOUT,PTYP,X9,XCNP,XMDUZ,XMHOLD,XMZ,Y,ZN,ZTREQ,ZTSK
+7 DO NOW^%DTC
SET PRCFKEY=%_"-"_DUZ
+8 SET PRCFRT=0
SET X=PRCF("BTCH")
+9 SET DIC=421.2
SET DIC(0)="XMN"
SET DIC("S")="S XXX=^(0) I $P(XXX,U,4)="""",$P(XXX,U,3)=""B"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
+10 DO ^DIC
KILL DIC,XXX
IF Y<0
SET PRCOUT=1
GOTO OUT
+11 SET PBAT=$PIECE(Y,U,2)
SET PBATN=+Y
SET $PIECE(^PRCF(421.2,PBATN,0),"^",15)=PRCFKEY
SET ^PRCF(421.2,"AD",PRCFKEY,PBATN)=""
+12 IF '$DATA(^PRCF(421.2,"AD",PRCFKEY))
SET PRCOUT=1
GOTO OUT
+13 ;
+14 NEW PBATN,PBAT,DIE,BY,FR,TO,FLDS
+15 KILL ^TMP("PRCFBTCH",$JOB)
+16 DO DT^DICRW
+17 FOR
SET PBATN=$ORDER(^PRCF(421.2,"AD",PRCFKEY,0))
if +PBATN=0
QUIT
SET PBAT=$PIECE(^PRCF(421.2,PBATN,0),"^")
Begin DoDot:1
+18 IF $DATA(^PRCF(423,"AD",PBAT))
SET N=0
FOR
SET N=$ORDER(^PRCF(423,"AD",PBAT,N))
if N'=+N
QUIT
SET ^PRCF(423,"AK",PRCFKEY,N)=""
SET $PIECE(^PRCF(423,N,"TRANS"),"^",11)=PRCFKEY
if "ISMPRC"[PRCFASYS
DO ^PRCFAIS
if "FEEFENLOGCAPIRS"[PRCFASYS
DO TX2^PRCFAIS
QUIT
+19 IF $GET(PRCOUT)]""
IF PRCOUT=1
QUIT
+20 if +PBATN'>0
QUIT
+21 SET DA=PBATN
+22 if $GET(P)]""
SET PX=P
+23 DO NOW^%DTC
+24 SET XDT=%
+25 SET X1=$PIECE(PRC("PER"),"^",2)
+26 SET $PIECE(^PRCF(421.2,DA,0),"^",4+PRCFRT)=XDT
+27 KILL XDT
+28 SET MESSAGE=""
+29 IF PRCFRT=0
DO ENCODE^PRCFAES1(DA,DUZ,.MESSAGE)
+30 IF PRCFRT=3
DO ENCODE^PRCFAES2(DA,DUZ,.MESSAGE)
+31 KILL MESSAGE
+32 KILL P
IF $DATA(PX)
SET P=PX
KILL PX
QUIT
+33 QUIT
End DoDot:1
KILL ^PRCF(421.2,"AD",PRCFKEY,PBATN)
SET $PIECE(^PRCF(421.2,PBATN,0),"^",15)=""
SET I=1
+34 if $GET(PRCOUT)
GOTO OUT
+35 KILL ^TMP("PRCFBTCH",$JOB)
+36 SET ZTIO=$ORDER(^PRC(411,PRC("SITE"),2,"AC","S",""))
SET ZTSAVE("*")=""
SET ZTRTN="DQ^PRCFACBT"
SET ZTDESC="Transmit Code sheets"
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
KILL IO("Q")
+37 QUIT
DQ ;Entry point to transmit code sheets in background
+1 SET IOP=IO
SET DIC="^PRCF(423,"
SET L=0
SET BY="[PRCFA BATCH TRANSMIT SORT]"
SET FLDS="[PRCFA BACKGROUND TRANSMIT]"
SET (FR,TO)=PRCFKEY
SET PRCFX=""
SET DIOEND="W @IOF"
+2 DO EN1^DIP
+3 ;this section will take the globals created during the print and
+4 ;give them to mailman for transmission
+5 SET N=0
FOR
SET N=$ORDER(^TMP("PRCFBTCH",$JOB,N))
if N'=+N
QUIT
SET PTYP=$ORDER(^PRCF(423.9,"AC",N,0))
if PTYP=""
QUIT
IF $PIECE(^PRCF(423.9,PTYP,0),"^",4)["Y"
Begin DoDot:1
+6 SET M=0
FOR
SET M=$ORDER(^TMP("PRCFBTCH",$JOB,N,M))
if M=""
QUIT
Begin DoDot:2
+7 if '$DATA(^PRCF(423.9,PTYP,0))
QUIT
if "3,1,4,2,9,10,12"[N
Begin DoDot:3
+8 ;TAKE 4th '-' PIECE OF BATCH NUMBER AND MAKE IT INTO MMCCC
+9 ; WHERE MM = MONTH
+10 ; CCC = LAST 3 DIGITS OF COUNTER VALUE
+11 SET SHRINK=$GET(^TMP("PRCFBTCH",$JOB,N,M,1,0))
if SHRINK=""
QUIT
IF $PIECE(SHRINK,".",3)=999
SET SHRINK1=$PIECE(SHRINK,".",6)
SET SHRINK2=$EXTRACT(SHRINK1,1,2)_$EXTRACT(SHRINK1,$LENGTH(SHRINK1)-2,99)
SET $PIECE(SHRINK,".",6)=SHRINK2
SET ^TMP("PRCFBTCH",$JOB,N,M,1,0)=SHRINK
+12 KILL SHRINK,SHRINK1,SHRINK2
QUIT
End DoDot:3
+13 SET M1=$PIECE(M,"-",4)
SET M2=$EXTRACT(M1,1,2)_$EXTRACT(M1,$LENGTH(M1)-2,99)
SET MM=$PIECE(M,"-",1,3)_"-"_M2
KILL M1,M2
Begin DoDot:3
+14 KILL ADD
SET ADD=$PIECE($GET(^PRCF(423.9,PTYP,0)),U,2)
if ADD]""
SET XMY(ADD)=""
if $GET(PRCFA("EDI"))]""
SET XMY(PRCFA("EDI"))=""
if $GET(PRCFA("ISM"))]""
SET XMY(PRCFA("ISM"))=""
KILL PRCFA("EDI"),PRCFA("ISM")
+15 KILL ADD
+16 IF $DATA(^PRCF(423.9,PTYP,1,0))
Begin DoDot:4
+17 SET L=0
FOR
SET L=$ORDER(^PRCF(423.9,PTYP,1,L))
if L'=+L
QUIT
IF $DATA(^PRCF(423.9,PTYP,1,L,0))
SET ADD=$PIECE(^(0),"^",1)
SET XMY(ADD)=""
+18 QUIT
End DoDot:4
End DoDot:3
+19 SET XMDUZ=DUZ
SET XMSUB="ISMS/EDI BATCH "_MM
SET XMTEXT="^TMP(""PRCFBTCH"","_$JOB_","_N_","""_M_""","
+20 DO XMD
+21 IF $DATA(M)
IF M[""
SET X=$ORDER(^PRCF(421.2,"B",M,0))
if X=""
QUIT
+22 if $DATA(^PRCF(421.2,X,0))
SET $PIECE(^(0),"^",12)=XMZ
SET ^PRCF(421.2,"D",XMZ,X)=""
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 SET N=0
FOR
SET N=$ORDER(^PRCF(423,"AK",PRCFKEY,N))
if 'N
QUIT
SET $PIECE(^PRCF(423,N,"TRANS"),"^",11)=""
+26 KILL %,%DT,%I,BATCH,BATTYPE,DP,I,J,K,L,M,N,PRCFX,PTYP,X,Y,Z1,Z2
OUT SET ZTREQ="@"
KILL PRCF("BTCH"),^TMP("PRCFBTCH",$JOB),^PRCF(423,"AK",PRCFKEY),PRCFKEY
+1 QUIT
+2 ;
XMD NEW I,J,K,L,M,N
+1 DO ^XMD
+2 if $DATA(PRCOPODA)
SET $PIECE(^PRC(442,PRCOPODA,12),U,10)=XMZ
+3 QUIT
+4 ;
