PRCPSMCS ;WISC/RFJ-create and transmit isms code sheet from tmp ;7/8/96 9:30 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
TRANSMIT(V1,V2,V3,V4,V5,V6) ; transmit code sheets from tmp global
; v1=station number
; v2=transaction code (BAL or PHA, etc)
; v3=reference number for header
; v4=1stQueue^2ndQueue^... (form ISM or ISM^EDP)
; v5=receiving station number for control segment
; v6=transaction interface version number...padded to 3 numbers
; with leading zeros
; tmp($j,"string",1:n)=code sheet data
; returns prcpxmz(sequence number)=mailman message number
;
N %,CONTROL,COUNT,CSHEET,DATA,LASTONE,LINE,LINECNT,SEQUENCE,SIZE,XMZ
; get control segment
S CONTROL=$$CONTROL(V1,V2,V3,V5,$G(V6))
;
K ^TMP($J,"PRCPSMC0"),PRCPXMZ
;
; move code sheets to message number in tmp global
S SEQUENCE=1,LINE=2,(SIZE,COUNT,CSHEET)=0 F S CSHEET=$O(^TMP($J,"STRING",CSHEET)) Q:'CSHEET S DATA=^(CSHEET),COUNT=COUNT+1 D
. ;
. ; check for last code sheet => set flag
. I '$O(^TMP($J,"STRING",CSHEET)) S LASTONE=1,DATA=DATA_"$"
. ;
. ; calculate message size
. S SIZE=SIZE+$L(DATA) I SIZE>30000,'$G(LASTONE) S DATA=DATA_$C(126)
. ;
. ; build message in tmp
. S ^TMP($J,"PRCPSMC0",SEQUENCE,LINE,0)=DATA,LINE=LINE+1
. ;
. ; increment counters if size exceeds 30k
. I '$G(LASTONE),SIZE>30000 S SEQUENCE=SEQUENCE+1,LINE=2,SIZE=$L(DATA)
;
; get line count segment if required by transaction code
I "BAL"[V2 S LINECNT=$$LINECNT(COUNT,V3)
;
; put control headers on code sheets and transmit
S $P(CONTROL,"^",9)=$E("000",$L(SEQUENCE)+1,3)_SEQUENCE
F COUNT=1:1:SEQUENCE Q:'$D(^TMP($J,"PRCPSMC0",COUNT)) D
. ;
. ; set control header to current sequence number (stored in count)
. S $P(CONTROL,"^",8)=$E("000",$L(COUNT)+1,3)_COUNT,^TMP($J,"PRCPSMC0",COUNT,1,0)=CONTROL_$S(COUNT=1&($D(LINECNT)):LINECNT,1:"")
. ;
. ; create and transmit mail message
. D MAILMSG(COUNT,SEQUENCE,V2,V4)
. S PRCPXMZ(COUNT)=+$G(XMZ)
K ^TMP($J,"PRCPSMC0")
Q
;
;
CONTROL(V1,V2,V3,V4,V5) ; build control segment
; v1=station number
; v2=transaction code
; v3=reference number
; v4=receiving station number
; v5=transaction intreface version number
; returns control segment string
N %,%H,%I,DATE,NOW,TIME,VERSION,X,Y
D NOW^%DTC S NOW=%,TIME=$E($P(%,".",2)_"000000",1,6),X1=$P(NOW,"."),X2=$E(NOW,1,3)_"0101" D ^%DTC S X=X+1,X=$E("000",$L(X)+1,3)_X,DATE=($E(NOW)+17)_$E(NOW,2,3)_X
S VERSION=$S($G(V5)>0:V5,1:40)
S VERSION=$E("000",$L(VERSION)+1,3)_VERSION
Q "ISM^"_$E(" ",$L(V1)+1,3)_V1_"^"_$E(" ",$L(V4)+1,3)_V4_"^"_$E(" ",$L(V2)+1,3)_V2_"^"_DATE_"^"_TIME_"^"_V3_$E(" ",$L(V3)+1,20)_"^001^001^"_VERSION_"^|"
;
;
LINECNT(V1,V2) ;line count segment
; v1=line count
; v2=reference number
; returns line count segment
Q "LC^"_V1_"^"_V2_"^|"
;
;
MAILMSG(V1,V2,V3,V4) ;create mail message
; v1=sequence number
; v2=total sequences
; v3=transaction type
; v4=1stQueue^2ndQueue^... (form ISM or ISM^EDP)
; returns xmz message number
N %,DA,DIC,GROUP,XCNP,XMDUZ,XMTEXT,XMY
;
; set group variable to send messages to mail group
S GROUP=0
;
; build receiving queue and user array
F %=1:1 Q:$P(V4,"^",%)="" S XMY("XXX@Q-"_$P(V4,"^",%)_".DOMAIN.EXT")="" I $G(GROUP) S XMY("G."_$P(V4,"^",%))=""
S DA=+$P($G(^PRCD(420.4,+$O(^PRCD(420.4,"B",V3,0)),0)),"^",4),%=0 F S %=$O(^PRCF(423.9,DA,1,%)) Q:'% S XMDUZ=+$G(^(%,0)) I XMDUZ S XMY(XMDUZ)=""
S XMDUZ=DUZ,XMTEXT="^TMP($J,""PRCPSMC0"","_V1_",",XMSUB=V3_" TRANSACTION TO Q-"_$TR(V4,"^","/")_" (MSG "_V1_" OF "_V2_")"
K XMZ D ^XMD Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSMCS 3761 printed Nov 22, 2024@17:25:59 Page 2
PRCPSMCS ;WISC/RFJ-create and transmit isms code sheet from tmp ;7/8/96 9:30 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
TRANSMIT(V1,V2,V3,V4,V5,V6) ; transmit code sheets from tmp global
+1 ; v1=station number
+2 ; v2=transaction code (BAL or PHA, etc)
+3 ; v3=reference number for header
+4 ; v4=1stQueue^2ndQueue^... (form ISM or ISM^EDP)
+5 ; v5=receiving station number for control segment
+6 ; v6=transaction interface version number...padded to 3 numbers
+7 ; with leading zeros
+8 ; tmp($j,"string",1:n)=code sheet data
+9 ; returns prcpxmz(sequence number)=mailman message number
+10 ;
+11 NEW %,CONTROL,COUNT,CSHEET,DATA,LASTONE,LINE,LINECNT,SEQUENCE,SIZE,XMZ
+12 ; get control segment
+13 SET CONTROL=$$CONTROL(V1,V2,V3,V5,$GET(V6))
+14 ;
+15 KILL ^TMP($JOB,"PRCPSMC0"),PRCPXMZ
+16 ;
+17 ; move code sheets to message number in tmp global
+18 SET SEQUENCE=1
SET LINE=2
SET (SIZE,COUNT,CSHEET)=0
FOR
SET CSHEET=$ORDER(^TMP($JOB,"STRING",CSHEET))
if 'CSHEET
QUIT
SET DATA=^(CSHEET)
SET COUNT=COUNT+1
Begin DoDot:1
+19 ;
+20 ; check for last code sheet => set flag
+21 IF '$ORDER(^TMP($JOB,"STRING",CSHEET))
SET LASTONE=1
SET DATA=DATA_"$"
+22 ;
+23 ; calculate message size
+24 SET SIZE=SIZE+$LENGTH(DATA)
IF SIZE>30000
IF '$GET(LASTONE)
SET DATA=DATA_$CHAR(126)
+25 ;
+26 ; build message in tmp
+27 SET ^TMP($JOB,"PRCPSMC0",SEQUENCE,LINE,0)=DATA
SET LINE=LINE+1
+28 ;
+29 ; increment counters if size exceeds 30k
+30 IF '$GET(LASTONE)
IF SIZE>30000
SET SEQUENCE=SEQUENCE+1
SET LINE=2
SET SIZE=$LENGTH(DATA)
End DoDot:1
+31 ;
+32 ; get line count segment if required by transaction code
+33 IF "BAL"[V2
SET LINECNT=$$LINECNT(COUNT,V3)
+34 ;
+35 ; put control headers on code sheets and transmit
+36 SET $PIECE(CONTROL,"^",9)=$EXTRACT("000",$LENGTH(SEQUENCE)+1,3)_SEQUENCE
+37 FOR COUNT=1:1:SEQUENCE
if '$DATA(^TMP($JOB,"PRCPSMC0",COUNT))
QUIT
Begin DoDot:1
+38 ;
+39 ; set control header to current sequence number (stored in count)
+40 SET $PIECE(CONTROL,"^",8)=$EXTRACT("000",$LENGTH(COUNT)+1,3)_COUNT
SET ^TMP($JOB,"PRCPSMC0",COUNT,1,0)=CONTROL_$SELECT(COUNT=1&($DATA(LINECNT)):LINECNT,1:"")
+41 ;
+42 ; create and transmit mail message
+43 DO MAILMSG(COUNT,SEQUENCE,V2,V4)
+44 SET PRCPXMZ(COUNT)=+$GET(XMZ)
End DoDot:1
+45 KILL ^TMP($JOB,"PRCPSMC0")
+46 QUIT
+47 ;
+48 ;
CONTROL(V1,V2,V3,V4,V5) ; build control segment
+1 ; v1=station number
+2 ; v2=transaction code
+3 ; v3=reference number
+4 ; v4=receiving station number
+5 ; v5=transaction intreface version number
+6 ; returns control segment string
+7 NEW %,%H,%I,DATE,NOW,TIME,VERSION,X,Y
+8 DO NOW^%DTC
SET NOW=%
SET TIME=$EXTRACT($PIECE(%,".",2)_"000000",1,6)
SET X1=$PIECE(NOW,".")
SET X2=$EXTRACT(NOW,1,3)_"0101"
DO ^%DTC
SET X=X+1
SET X=$EXTRACT("000",$LENGTH(X)+1,3)_X
SET DATE=($EXTRACT(NOW)+17)_$EXTRACT(NOW,2,3)_X
+9 SET VERSION=$SELECT($GET(V5)>0:V5,1:40)
+10 SET VERSION=$EXTRACT("000",$LENGTH(VERSION)+1,3)_VERSION
+11 QUIT "ISM^"_$EXTRACT(" ",$LENGTH(V1)+1,3)_V1_"^"_$EXTRACT(" ",$LENGTH(V4)+1,3)_V4_"^"_$EXTRACT(" ",$LENGTH(V2)+1,3)_V2_"^"_DATE_"^"_TIME_"^"_V3_$EXTRACT(" ",$LENGTH(V3)+1,20)_"^001^001^"_VERSION_"^|"
+12 ;
+13 ;
LINECNT(V1,V2) ;line count segment
+1 ; v1=line count
+2 ; v2=reference number
+3 ; returns line count segment
+4 QUIT "LC^"_V1_"^"_V2_"^|"
+5 ;
+6 ;
MAILMSG(V1,V2,V3,V4) ;create mail message
+1 ; v1=sequence number
+2 ; v2=total sequences
+3 ; v3=transaction type
+4 ; v4=1stQueue^2ndQueue^... (form ISM or ISM^EDP)
+5 ; returns xmz message number
+6 NEW %,DA,DIC,GROUP,XCNP,XMDUZ,XMTEXT,XMY
+7 ;
+8 ; set group variable to send messages to mail group
+9 SET GROUP=0
+10 ;
+11 ; build receiving queue and user array
+12 FOR %=1:1
if $PIECE(V4,"^",%)=""
QUIT
SET XMY("XXX@Q-"_$PIECE(V4,"^",%)_".DOMAIN.EXT")=""
IF $GET(GROUP)
SET XMY("G."_$PIECE(V4,"^",%))=""
+13 SET DA=+$PIECE($GET(^PRCD(420.4,+$ORDER(^PRCD(420.4,"B",V3,0)),0)),"^",4)
SET %=0
FOR
SET %=$ORDER(^PRCF(423.9,DA,1,%))
if '%
QUIT
SET XMDUZ=+$GET(^(%,0))
IF XMDUZ
SET XMY(XMDUZ)=""
+14 SET XMDUZ=DUZ
SET XMTEXT="^TMP($J,""PRCPSMC0"","_V1_","
SET XMSUB=V3_" TRANSACTION TO Q-"_$TRANSLATE(V4,"^","/")_" (MSG "_V1_" OF "_V2_")"
+15 KILL XMZ
DO ^XMD
QUIT
