- 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 Feb 18, 2025@23:30:59 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