- PRCHQ4A ;(WASH IRMFO)/LKG-RFQ Set up Transmission Records ; [8/11/98 9:47am]
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- CT(PRCA) ;Set up Control segment for Text Message (864)
- N PRCD,PRCE,PRCF,PRCY,PRCZ,X,Y
- S PRCD=$G(^PRC(444,PRCDA,7,PRCA,0)) Q:PRCD=""
- S PRCE=$G(^PRC(444,PRCDA,7,PRCA,1))
- S PRCF=$P(PRCD,U,6),X=$P(PRCF,".") D JDN^PRCUTL
- S X=$P(PRCF,".",2),X=X_$E("000000",$L(X)+1,6)
- S PRCY="CT^"_$P(PRCD,U,5)_"^"_$P(PRCE,U)_"^"_Y_"^"_X_"^"_$P(PRCD,U,8)_"^"_$P(PRCD,U,9)_"^0^0^|"
- S ^TMP($J,"STRING",1)=PRCY
- I $P(PRCY,U,2)'>0 S PRCZ(1)="Sender's Message # is missing"
- I $P(PRCY,U,3)="" S PRCZ(2)="Message Description is missing"
- I $P(PRCY,U,4)'?7N S PRCZ(3)="Invalid Effective Date"
- I $P(PRCY,U,5)'?6N S PRCZ(4)="Invalid Effective Time"
- I $P(PRCY,U,6)="" S PRCZ(5)="Official's Name is missing"
- I $P(PRCY,U,7)="" S PRCZ(6)="Official's Phone # is missing"
- I $D(PRCZ) S PRCERR=3 D:'$D(ZTQUEUED) EN^DDIOL(.PRCZ)
- Q
- VEL(PRCA,PRCN) ;Get vendor recipients for 864 Text Message; invokes VE^PRCHQ4
- N PRCW,PRCX,PRCY,X S PRCX=0,PRCW=0
- F S PRCX=$O(^PRC(444,PRCDA,7,PRCA,3,PRCX)) Q:PRCX'?1.N D
- . S PRCY=$P($G(^PRC(444,PRCDA,7,PRCA,3,PRCX,0)),U) Q:PRCY=""
- . 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))
- . I X="" D DUNERR^PRCHQ4(PRCY) Q
- . D VE^PRCHQ4(X,.PRCN) S PRCW=PRCW+1
- I $P($G(^PRC(444,PRCDA,7,PRCA,1)),U,2)="y" D VE^PRCHQ4("PUBLIC",.PRCN) S PRCW=PRCW+1
- Q PRCW
- TRANS840(PRCTYPE) ;RFQ transmission code
- ;;Requires input variables: PRCDA,PRCRFQ
- K ^TMP($J,"STRING"),^TMP($J,"VE") N PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
- D HE^PRCHQ4 S PRCCOUNT=1
- S $P(^TMP($J,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
- I $P(^TMP($J,"STRING",1),U,18)=0 D EN^DDIOL("No Vendors for Electronic Transmission")
- D ST^PRCHQ4(.PRCCOUNT)
- D MI^PRCHQ4(PRCTYPE,.PRCCOUNT)
- D AC^PRCHQ4(.PRCCOUNT)
- S $P(^TMP($J,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,4)",.PRCCOUNT)
- D IT^PRCHQ4(.PRCCOUNT)
- S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
- I PRCSORC="" S PRCERR=4 D EN^DDIOL("Sending Station not in File 411")
- I $G(PRCERR)!($P($G(^TMP($J,"STRING",1)),U,18)=0) K ^TMP($J,"STRING"),^TMP($J,"VE") Q
- S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
- D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
- K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
- I XMZ>0 D
- . N PRCV
- . S $P(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
- . S X=$P($$NET^XMRENT(PRCPXMZ(XMZ)),U) S %DT="ST" D ^%DT
- . S:Y'=-1 $P(^PRC(444,PRCDA,1),U,18)=Y
- . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
- . D EN^DDIOL(X)
- . S PRCV=""
- . 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)
- K ^TMP($J,"VE")
- Q
- TRANS864 ;864 TEXT MESSAGE transmission code
- ;;Requires input variables: PRCDA, PRCDA2,PRCRFQ
- K ^TMP($J,"STRING"),^TMP($J,"VE") N PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
- D CT^PRCHQ4A(PRCDA2) S PRCCOUNT=1
- I $G(PRCERR) K ^TMP($J,"STRING") Q
- S $P(^TMP($J,"STRING",1),U,9)=$$VEL^PRCHQ4A(PRCDA2,.PRCCOUNT)
- 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
- S $P(^TMP($J,"STRING",1),U,8)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
- 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
- S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
- I PRCSORC="" S PRCERR=4 D:'$D(ZTQUEUED) EN^DDIOL("Sending Station not in File 411") K ^TMP($J,"STRING"),^TMP($J,"VE") Q
- S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
- D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"TXT",PRCRFQ,PRCDEST,200,1)
- K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
- I XMZ>0 D
- . N PRCV
- . S $P(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
- . S X="MailMan Msg #: "_PRCPXMZ(XMZ)
- . D:'$D(ZTQUEUED) EN^DDIOL(X)
- . S PRCV=""
- . 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))
- K ^TMP($J,"VE")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ4A 4189 printed Feb 18, 2025@23:36:10 Page 2
- PRCHQ4A ;(WASH IRMFO)/LKG-RFQ Set up Transmission Records ; [8/11/98 9:47am]
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- CT(PRCA) ;Set up Control segment for Text Message (864)
- +1 NEW PRCD,PRCE,PRCF,PRCY,PRCZ,X,Y
- +2 SET PRCD=$GET(^PRC(444,PRCDA,7,PRCA,0))
- if PRCD=""
- QUIT
- +3 SET PRCE=$GET(^PRC(444,PRCDA,7,PRCA,1))
- +4 SET PRCF=$PIECE(PRCD,U,6)
- SET X=$PIECE(PRCF,".")
- DO JDN^PRCUTL
- +5 SET X=$PIECE(PRCF,".",2)
- SET X=X_$EXTRACT("000000",$LENGTH(X)+1,6)
- +6 SET PRCY="CT^"_$PIECE(PRCD,U,5)_"^"_$PIECE(PRCE,U)_"^"_Y_"^"_X_"^"_$PIECE(PRCD,U,8)_"^"_$PIECE(PRCD,U,9)_"^0^0^|"
- +7 SET ^TMP($JOB,"STRING",1)=PRCY
- +8 IF $PIECE(PRCY,U,2)'>0
- SET PRCZ(1)="Sender's Message # is missing"
- +9 IF $PIECE(PRCY,U,3)=""
- SET PRCZ(2)="Message Description is missing"
- +10 IF $PIECE(PRCY,U,4)'?7N
- SET PRCZ(3)="Invalid Effective Date"
- +11 IF $PIECE(PRCY,U,5)'?6N
- SET PRCZ(4)="Invalid Effective Time"
- +12 IF $PIECE(PRCY,U,6)=""
- SET PRCZ(5)="Official's Name is missing"
- +13 IF $PIECE(PRCY,U,7)=""
- SET PRCZ(6)="Official's Phone # is missing"
- +14 IF $DATA(PRCZ)
- SET PRCERR=3
- if '$DATA(ZTQUEUED)
- DO EN^DDIOL(.PRCZ)
- +15 QUIT
- VEL(PRCA,PRCN) ;Get vendor recipients for 864 Text Message; invokes VE^PRCHQ4
- +1 NEW PRCW,PRCX,PRCY,X
- SET PRCX=0
- SET PRCW=0
- +2 FOR
- SET PRCX=$ORDER(^PRC(444,PRCDA,7,PRCA,3,PRCX))
- if PRCX'?1.N
- QUIT
- Begin DoDot:1
- +3 SET PRCY=$PIECE($GET(^PRC(444,PRCDA,7,PRCA,3,PRCX,0)),U)
- if PRCY=""
- QUIT
- +4 SET X=$SELECT(PRCY["PRC(440,":$PIECE($GET(^PRC(440,$PIECE(PRCY,";"),7)),U,12),1:$PIECE($GET(^PRC(444.1,$PIECE(PRCY,";"),0)),U,2))
- +5 IF X=""
- DO DUNERR^PRCHQ4(PRCY)
- QUIT
- +6 DO VE^PRCHQ4(X,.PRCN)
- SET PRCW=PRCW+1
- End DoDot:1
- +7 IF $PIECE($GET(^PRC(444,PRCDA,7,PRCA,1)),U,2)="y"
- DO VE^PRCHQ4("PUBLIC",.PRCN)
- SET PRCW=PRCW+1
- +8 QUIT PRCW
- TRANS840(PRCTYPE) ;RFQ transmission code
- +1 ;;Requires input variables: PRCDA,PRCRFQ
- +2 KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
- NEW PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
- +3 DO HE^PRCHQ4
- SET PRCCOUNT=1
- +4 SET $PIECE(^TMP($JOB,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
- +5 IF $PIECE(^TMP($JOB,"STRING",1),U,18)=0
- DO EN^DDIOL("No Vendors for Electronic Transmission")
- +6 DO ST^PRCHQ4(.PRCCOUNT)
- +7 DO MI^PRCHQ4(PRCTYPE,.PRCCOUNT)
- +8 DO AC^PRCHQ4(.PRCCOUNT)
- +9 SET $PIECE(^TMP($JOB,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,4)",.PRCCOUNT)
- +10 DO IT^PRCHQ4(.PRCCOUNT)
- +11 SET PRCSORC=$ORDER(^PRC(411,"B",$PIECE(PRCRFQ,"-"),""))
- +12 IF PRCSORC=""
- SET PRCERR=4
- DO EN^DDIOL("Sending Station not in File 411")
- +13 IF $GET(PRCERR)!($PIECE($GET(^TMP($JOB,"STRING",1)),U,18)=0)
- KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
- QUIT
- +14 SET PRCDEST=$SELECT($PIECE($GET(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
- +15 DO TRANSMIT^PRCPSMCS($PIECE(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
- +16 KILL ^TMP($JOB,"STRING")
- SET XMZ=$ORDER(PRCPXMZ(0))
- +17 IF XMZ>0
- Begin DoDot:1
- +18 NEW PRCV
- +19 SET $PIECE(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
- +20 SET X=$PIECE($$NET^XMRENT(PRCPXMZ(XMZ)),U)
- SET %DT="ST"
- DO ^%DT
- +21 if Y'=-1
- SET $PIECE(^PRC(444,PRCDA,1),U,18)=Y
- +22 SET X="MailMan Msg #: "_PRCPXMZ(XMZ)
- +23 DO EN^DDIOL(X)
- +24 SET PRCV=""
- +25 FOR
- SET PRCV=$ORDER(^TMP($JOB,"VE",PRCV))
- if PRCV=""
- QUIT
- DO ENTER^PRCOEDI(PRCRFQ,"RFQ",PRCPXMZ(XMZ),PRCV,$PIECE($GET(^PRC(444,PRCDA,0)),U,4),PRCDA,PRCTYPE)
- End DoDot:1
- +26 KILL ^TMP($JOB,"VE")
- +27 QUIT
- TRANS864 ;864 TEXT MESSAGE transmission code
- +1 ;;Requires input variables: PRCDA, PRCDA2,PRCRFQ
- +2 KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
- NEW PRCCOUNT,PRCPXMZ,XMZ,X,PRCSORC,PRCDEST
- +3 DO CT^PRCHQ4A(PRCDA2)
- SET PRCCOUNT=1
- +4 IF $GET(PRCERR)
- KILL ^TMP($JOB,"STRING")
- QUIT
- +5 SET $PIECE(^TMP($JOB,"STRING",1),U,9)=$$VEL^PRCHQ4A(PRCDA2,.PRCCOUNT)
- +6 IF $PIECE(^TMP($JOB,"STRING",1),U,9)=0
- if '$DATA(ZTQUEUED)
- DO EN^DDIOL("No Vendors for Electronic Transmission")
- KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
- SET PRCERR=1
- QUIT
- +7 SET $PIECE(^TMP($JOB,"STRING",1),U,8)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
- +8 IF $PIECE(^TMP($JOB,"STRING",1),U,8)'>0
- if '$DATA(ZTQUEUED)
- DO EN^DDIOL("No text in message")
- KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
- SET PRCERR=2
- QUIT
- +9 SET PRCSORC=$ORDER(^PRC(411,"B",$PIECE(PRCRFQ,"-"),""))
- +10 IF PRCSORC=""
- SET PRCERR=4
- if '$DATA(ZTQUEUED)
- DO EN^DDIOL("Sending Station not in File 411")
- KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
- QUIT
- +11 SET PRCDEST=$SELECT($PIECE($GET(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
- +12 DO TRANSMIT^PRCPSMCS($PIECE(PRCRFQ,"-"),"TXT",PRCRFQ,PRCDEST,200,1)
- +13 KILL ^TMP($JOB,"STRING")
- SET XMZ=$ORDER(PRCPXMZ(0))
- +14 IF XMZ>0
- Begin DoDot:1
- +15 NEW PRCV
- +16 SET $PIECE(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
- +17 SET X="MailMan Msg #: "_PRCPXMZ(XMZ)
- +18 if '$DATA(ZTQUEUED)
- DO EN^DDIOL(X)
- +19 SET PRCV=""
- +20 FOR
- SET PRCV=$ORDER(^TMP($JOB,"VE",PRCV))
- if PRCV=""
- QUIT
- DO ENTER^PRCOEDI(PRCRFQ,"TXT",PRCPXMZ(XMZ),PRCV,$PIECE($GET(^PRC(444,PRCDA,0)),U,4),PRCDA,"",$PIECE($GET(^PRC(444,PRCDA,7,PRCDA2,0)),U,5))
- End DoDot:1
- +21 KILL ^TMP($JOB,"VE")
- +22 QUIT