Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHQ4A

PRCHQ4A.m

Go to the documentation of this file.
  1. PRCHQ4A ;(WASH IRMFO)/LKG-RFQ Set up Transmission Records ; [8/11/98 9:47am]
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. CT(PRCA) ;Set up Control segment for Text Message (864)
  1. N PRCD,PRCE,PRCF,PRCY,PRCZ,X,Y
  1. S PRCD=$G(^PRC(444,PRCDA,7,PRCA,0)) Q:PRCD=""
  1. S PRCE=$G(^PRC(444,PRCDA,7,PRCA,1))
  1. S PRCF=$P(PRCD,U,6),X=$P(PRCF,".") D JDN^PRCUTL
  1. S X=$P(PRCF,".",2),X=X_$E("000000",$L(X)+1,6)
  1. S PRCY="CT^"_$P(PRCD,U,5)_"^"_$P(PRCE,U)_"^"_Y_"^"_X_"^"_$P(PRCD,U,8)_"^"_$P(PRCD,U,9)_"^0^0^|"
  1. S ^TMP($J,"STRING",1)=PRCY
  1. I $P(PRCY,U,2)'>0 S PRCZ(1)="Sender's Message # is missing"
  1. I $P(PRCY,U,3)="" S PRCZ(2)="Message Description is missing"
  1. I $P(PRCY,U,4)'?7N S PRCZ(3)="Invalid Effective Date"
  1. I $P(PRCY,U,5)'?6N S PRCZ(4)="Invalid Effective Time"
  1. I $P(PRCY,U,6)="" S PRCZ(5)="Official's Name is missing"
  1. I $P(PRCY,U,7)="" S PRCZ(6)="Official's Phone # is missing"
  1. I $D(PRCZ) S PRCERR=3 D:'$D(ZTQUEUED) EN^DDIOL(.PRCZ)
  1. Q
  1. VEL(PRCA,PRCN) ;Get vendor recipients for 864 Text Message; invokes VE^PRCHQ4
  1. N PRCW,PRCX,PRCY,X S PRCX=0,PRCW=0
  1. F S PRCX=$O(^PRC(444,PRCDA,7,PRCA,3,PRCX)) Q:PRCX'?1.N D
  1. . S PRCY=$P($G(^PRC(444,PRCDA,7,PRCA,3,PRCX,0)),U) Q:PRCY=""
  1. . S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2))
  1. . I X="" D DUNERR^PRCHQ4(PRCY) Q
  1. . D VE^PRCHQ4(X,.PRCN) S PRCW=PRCW+1
  1. I $P($G(^PRC(444,PRCDA,7,PRCA,1)),U,2)="y" D VE^PRCHQ4("PUBLIC",.PRCN) S PRCW=PRCW+1
  1. Q PRCW
  1. TRANS840(PRCTYPE) ;RFQ transmission code
  1. ;;Requires input variables: PRCDA,PRCRFQ
  1. K ^TMP($J,"STRING"),^TMP($J,"VE") N PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
  1. D HE^PRCHQ4 S PRCCOUNT=1
  1. S $P(^TMP($J,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
  1. I $P(^TMP($J,"STRING",1),U,18)=0 D EN^DDIOL("No Vendors for Electronic Transmission")
  1. D ST^PRCHQ4(.PRCCOUNT)
  1. D MI^PRCHQ4(PRCTYPE,.PRCCOUNT)
  1. D AC^PRCHQ4(.PRCCOUNT)
  1. S $P(^TMP($J,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,4)",.PRCCOUNT)
  1. D IT^PRCHQ4(.PRCCOUNT)
  1. S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
  1. I PRCSORC="" S PRCERR=4 D EN^DDIOL("Sending Station not in File 411")
  1. I $G(PRCERR)!($P($G(^TMP($J,"STRING",1)),U,18)=0) K ^TMP($J,"STRING"),^TMP($J,"VE") Q
  1. S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
  1. D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
  1. K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
  1. I XMZ>0 D
  1. . N PRCV
  1. . S $P(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
  1. . S X=$P($$NET^XMRENT(PRCPXMZ(XMZ)),U) S %DT="ST" D ^%DT
  1. . S:Y'=-1 $P(^PRC(444,PRCDA,1),U,18)=Y
  1. . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
  1. . D EN^DDIOL(X)
  1. . S PRCV=""
  1. . F S PRCV=$O(^TMP($J,"VE",PRCV)) Q:PRCV="" D ENTER^PRCOEDI(PRCRFQ,"RFQ",PRCPXMZ(XMZ),PRCV,$P($G(^PRC(444,PRCDA,0)),U,4),PRCDA,PRCTYPE)
  1. K ^TMP($J,"VE")
  1. Q
  1. TRANS864 ;864 TEXT MESSAGE transmission code
  1. ;;Requires input variables: PRCDA, PRCDA2,PRCRFQ
  1. K ^TMP($J,"STRING"),^TMP($J,"VE") N PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
  1. D CT^PRCHQ4A(PRCDA2) S PRCCOUNT=1
  1. I $G(PRCERR) K ^TMP($J,"STRING") Q
  1. S $P(^TMP($J,"STRING",1),U,9)=$$VEL^PRCHQ4A(PRCDA2,.PRCCOUNT)
  1. I $P(^TMP($J,"STRING",1),U,9)=0 D:'$D(ZTQUEUED) EN^DDIOL("No Vendors for Electronic Transmission") K ^TMP($J,"STRING"),^TMP($J,"VE") S PRCERR=1 Q
  1. S $P(^TMP($J,"STRING",1),U,8)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
  1. I $P(^TMP($J,"STRING",1),U,8)'>0 D:'$D(ZTQUEUED) EN^DDIOL("No text in message") K ^TMP($J,"STRING"),^TMP($J,"VE") S PRCERR=2 Q
  1. S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
  1. I PRCSORC="" S PRCERR=4 D:'$D(ZTQUEUED) EN^DDIOL("Sending Station not in File 411") K ^TMP($J,"STRING"),^TMP($J,"VE") Q
  1. S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
  1. D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"TXT",PRCRFQ,PRCDEST,200,1)
  1. K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
  1. I XMZ>0 D
  1. . N PRCV
  1. . S $P(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
  1. . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
  1. . D:'$D(ZTQUEUED) EN^DDIOL(X)
  1. . S PRCV=""
  1. . F S PRCV=$O(^TMP($J,"VE",PRCV)) Q:PRCV="" D ENTER^PRCOEDI(PRCRFQ,"TXT",PRCPXMZ(XMZ),PRCV,$P($G(^PRC(444,PRCDA,0)),U,4),PRCDA,"",$P($G(^PRC(444,PRCDA,7,PRCDA2,0)),U,5))
  1. K ^TMP($J,"VE")
  1. Q