XPDTP ;SFISC/RSD - Transport using a Packman Message ;09/23/96 13:54
;;8.0;KERNEL;**21,40,44,713,738**;Jul 05, 1995;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
N DIFROM,DIR,DIRUT,DWPK,DWLW,DIC,I,J,XCN,XCNP,XMDISPI,XMDUN,XMDUZ,XMKEY,XMSCR,XMSUB,XMY,XMZ,X,Y,%
S DIFROM=1,DIR(0)="F^3:65",DIR("A")="Subject",DIR("?")="Enter the subject for this Packman Message",DIR("B")=XPDH
D ^DIR Q:$D(DIRUT)
S XMSUB=Y,XMDUZ=+DUZ
K ^TMP("XMP",$J)
W !,"Please enter description of Packman Message",!
S DWPK=1,DWLW=75,DIC="^TMP(""XMP"",$J," D EN^DIWE
KD D KIDS^XMP ;p713
S XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)="$KID "_XPDNM,XCNP=XCNP+1
D GS K:'$G(^XTMP("XPDT",XPDA)) ^(XPDA)
S $P(^XMB(3.9,XMZ,2,0),U,3,4)=XCNP_U_XCNP
;secure message & then send
D ^XMASEC Q:$D(DTOUT)!$D(DUOUT) D EN3^XMD
K ^TMP("XMP",$J)
Q
GS N GR,GCK,GL
S GCK="^XTMP(""XPDT"","_XPDA,GR=GCK_")",GCK=GCK_",",GL=$L(GCK)
;INSTALL NAME line will mark the begining of global for all lines until
;the next INSTALL NAME
S ^XMB(3.9,XMZ,2,XCNP,0)="**INSTALL NAME**",XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)=XPDNM,XCNP=XCNP+1
F S GR=$Q(@GR) Q:GR=""!($E(GR,1,GL)'=GCK) S ^XMB(3.9,XMZ,2,XCNP,0)=$P(GR,GCK,2),XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)=@GR,XCNP=XCNP+1
S ^XMB(3.9,XMZ,2,XCNP,0)="$END KID "_XPDNM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDTP 1313 printed Oct 16, 2024@18:05:22 Page 2
XPDTP ;SFISC/RSD - Transport using a Packman Message ;09/23/96 13:54
+1 ;;8.0;KERNEL;**21,40,44,713,738**;Jul 05, 1995;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW DIFROM,DIR,DIRUT,DWPK,DWLW,DIC,I,J,XCN,XCNP,XMDISPI,XMDUN,XMDUZ,XMKEY,XMSCR,XMSUB,XMY,XMZ,X,Y,%
+4 SET DIFROM=1
SET DIR(0)="F^3:65"
SET DIR("A")="Subject"
SET DIR("?")="Enter the subject for this Packman Message"
SET DIR("B")=XPDH
+5 DO ^DIR
if $DATA(DIRUT)
QUIT
+6 SET XMSUB=Y
SET XMDUZ=+DUZ
+7 KILL ^TMP("XMP",$JOB)
+8 WRITE !,"Please enter description of Packman Message",!
+9 SET DWPK=1
SET DWLW=75
SET DIC="^TMP(""XMP"",$J,"
DO EN^DIWE
KD ;p713
DO KIDS^XMP
+1 SET XCNP=XCNP+1
SET ^XMB(3.9,XMZ,2,XCNP,0)="$KID "_XPDNM
SET XCNP=XCNP+1
+2 DO GS
if '$GET(^XTMP("XPDT",XPDA))
KILL ^(XPDA)
+3 SET $PIECE(^XMB(3.9,XMZ,2,0),U,3,4)=XCNP_U_XCNP
+4 ;secure message & then send
+5 DO ^XMASEC
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
DO EN3^XMD
+6 KILL ^TMP("XMP",$JOB)
+7 QUIT
GS NEW GR,GCK,GL
+1 SET GCK="^XTMP(""XPDT"","_XPDA
SET GR=GCK_")"
SET GCK=GCK_","
SET GL=$LENGTH(GCK)
+2 ;INSTALL NAME line will mark the begining of global for all lines until
+3 ;the next INSTALL NAME
+4 SET ^XMB(3.9,XMZ,2,XCNP,0)="**INSTALL NAME**"
SET XCNP=XCNP+1
SET ^XMB(3.9,XMZ,2,XCNP,0)=XPDNM
SET XCNP=XCNP+1
+5 FOR
SET GR=$QUERY(@GR)
if GR=""!($EXTRACT(GR,1,GL)'=GCK)
QUIT
SET ^XMB(3.9,XMZ,2,XCNP,0)=$PIECE(GR,GCK,2)
SET XCNP=XCNP+1
SET ^XMB(3.9,XMZ,2,XCNP,0)=@GR
SET XCNP=XCNP+1
+6 SET ^XMB(3.9,XMZ,2,XCNP,0)="$END KID "_XPDNM
+7 QUIT
