PRCPSMCS.m

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 ---PRCPSMCS   3761     printed  Apr 23, 2025@18:30:25                                                                                                                                                                                                    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