source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4A.m@ 1150

Last change on this file since 1150 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
RevLine 
[613]1PRCHQ4A ;(WASH IRMFO)/LKG-RFQ Set up Transmission Records ; [8/11/98 9:47am]
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4CT(PRCA) ;Set up Control segment for Text Message (864)
5 N PRCD,PRCE,PRCF,PRCY,PRCZ,X,Y
6 S PRCD=$G(^PRC(444,PRCDA,7,PRCA,0)) Q:PRCD=""
7 S PRCE=$G(^PRC(444,PRCDA,7,PRCA,1))
8 S PRCF=$P(PRCD,U,6),X=$P(PRCF,".") D JDN^PRCUTL
9 S X=$P(PRCF,".",2),X=X_$E("000000",$L(X)+1,6)
10 S PRCY="CT^"_$P(PRCD,U,5)_"^"_$P(PRCE,U)_"^"_Y_"^"_X_"^"_$P(PRCD,U,8)_"^"_$P(PRCD,U,9)_"^0^0^|"
11 S ^TMP($J,"STRING",1)=PRCY
12 I $P(PRCY,U,2)'>0 S PRCZ(1)="Sender's Message # is missing"
13 I $P(PRCY,U,3)="" S PRCZ(2)="Message Description is missing"
14 I $P(PRCY,U,4)'?7N S PRCZ(3)="Invalid Effective Date"
15 I $P(PRCY,U,5)'?6N S PRCZ(4)="Invalid Effective Time"
16 I $P(PRCY,U,6)="" S PRCZ(5)="Official's Name is missing"
17 I $P(PRCY,U,7)="" S PRCZ(6)="Official's Phone # is missing"
18 I $D(PRCZ) S PRCERR=3 D:'$D(ZTQUEUED) EN^DDIOL(.PRCZ)
19 Q
20VEL(PRCA,PRCN) ;Get vendor recipients for 864 Text Message; invokes VE^PRCHQ4
21 N PRCW,PRCX,PRCY,X S PRCX=0,PRCW=0
22 F S PRCX=$O(^PRC(444,PRCDA,7,PRCA,3,PRCX)) Q:PRCX'?1.N D
23 . S PRCY=$P($G(^PRC(444,PRCDA,7,PRCA,3,PRCX,0)),U) Q:PRCY=""
24 . 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))
25 . I X="" D DUNERR^PRCHQ4(PRCY) Q
26 . D VE^PRCHQ4(X,.PRCN) S PRCW=PRCW+1
27 I $P($G(^PRC(444,PRCDA,7,PRCA,1)),U,2)="y" D VE^PRCHQ4("PUBLIC",.PRCN) S PRCW=PRCW+1
28 Q PRCW
29TRANS840(PRCTYPE) ;RFQ transmission code
30 ;;Requires input variables: PRCDA,PRCRFQ
31 K ^TMP($J,"STRING"),^TMP($J,"VE") N PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
32 D HE^PRCHQ4 S PRCCOUNT=1
33 S $P(^TMP($J,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
34 I $P(^TMP($J,"STRING",1),U,18)=0 D EN^DDIOL("No Vendors for Electronic Transmission")
35 D ST^PRCHQ4(.PRCCOUNT)
36 D MI^PRCHQ4(PRCTYPE,.PRCCOUNT)
37 D AC^PRCHQ4(.PRCCOUNT)
38 S $P(^TMP($J,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,4)",.PRCCOUNT)
39 D IT^PRCHQ4(.PRCCOUNT)
40 S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
41 I PRCSORC="" S PRCERR=4 D EN^DDIOL("Sending Station not in File 411")
42 I $G(PRCERR)!($P($G(^TMP($J,"STRING",1)),U,18)=0) K ^TMP($J,"STRING"),^TMP($J,"VE") Q
43 S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
44 D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
45 K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
46 I XMZ>0 D
47 . N PRCV
48 . S $P(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
49 . S X=$P($$NET^XMRENT(PRCPXMZ(XMZ)),U) S %DT="ST" D ^%DT
50 . S:Y'=-1 $P(^PRC(444,PRCDA,1),U,18)=Y
51 . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
52 . D EN^DDIOL(X)
53 . S PRCV=""
54 . 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)
55 K ^TMP($J,"VE")
56 Q
57TRANS864 ;864 TEXT MESSAGE transmission code
58 ;;Requires input variables: PRCDA, PRCDA2,PRCRFQ
59 K ^TMP($J,"STRING"),^TMP($J,"VE") N PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
60 D CT^PRCHQ4A(PRCDA2) S PRCCOUNT=1
61 I $G(PRCERR) K ^TMP($J,"STRING") Q
62 S $P(^TMP($J,"STRING",1),U,9)=$$VEL^PRCHQ4A(PRCDA2,.PRCCOUNT)
63 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
64 S $P(^TMP($J,"STRING",1),U,8)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
65 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
66 S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
67 I PRCSORC="" S PRCERR=4 D:'$D(ZTQUEUED) EN^DDIOL("Sending Station not in File 411") K ^TMP($J,"STRING"),^TMP($J,"VE") Q
68 S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
69 D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"TXT",PRCRFQ,PRCDEST,200,1)
70 K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
71 I XMZ>0 D
72 . N PRCV
73 . S $P(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
74 . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
75 . D:'$D(ZTQUEUED) EN^DDIOL(X)
76 . S PRCV=""
77 . 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))
78 K ^TMP($J,"VE")
79 Q
Note: See TracBrowser for help on using the repository browser.