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

PSXRXQU.m

Go to the documentation of this file.
  1. PSXRXQU ;BIR/BAB,WPB-CMOP RX QUEUE File Utility ;15-Nov-2013 13:10;DU
  1. ;;2.0;CMOP;**7,12,25,33,40,41,1013,54,1015,1018**;11 Apr 97;Build 21
  1. ;
  1. ;Reference to ^PS(55, supported by DBIA #2228
  1. ;Modified - IHS/MSC/PLS - 09/23/2011 - Line PID+9
  1. ; - 04/29/2013 - Line PID+13
  1. ; - 10/24/2013 - Line PID+18
  1. PURGE ;Purge 550.1 of any entries w/Message Status "IN TRANSITION"
  1. Q:'$D(^PSX(550.1,"AB")) S MSG="" F S MSG=$O(^PSX(550.1,"AB",MSG)) Q:'MSG S DIK=550.1,DA=MSG D ^DIK
  1. K DIK,MSG,DA
  1. Q
  1. ;-------------------------------------------------------------
  1. NEWMSG ;Increment & create entry in RX QUEUE file, put pid/demog in 'T' ; return PSXMSG, PSX=3
  1. ;550.1 has been dinumed
  1. D NOW^%DTC
  1. S PSXMSG=PSXMSG+1,X=PSXMSG
  1. K DO,DD S DIC(0)="L",DIC="^PSX(550.1,",DIC("DR")="1///3;2////"_%_";3////^S X=PSXBAT",DLAYGO=550.1
  1. D ^DIC K DIC,DUOUT,DTOUT
  1. MSH ; build patients MSH HL7 segment
  1. ;D RX5502 ;load RX,Fill,Pat,Ord
  1. D DEM^VADPT,ADD^VADPT,TSOUT^PSXUTL S ^PSX(550.1,PSXMSG,"T",1,0)="MSH|^~\&|VISTA||CMOP Automated System||"_PSXTS_"||ORM|"_PSXMSG_"|P|2.1|" K PSXTS ;*33
  1. S X1=$P(VADM(2),"^")
  1. S I="" F S I=$O(VAPA(I)) Q:I="" S VAPA(I)=$$STRIP(VAPA(I)) ; strip bad characters
  1. F YT=1:1:4 S VAPA(YT)=$TR(VAPA(YT),"\","/")
  1. PID ; build patients PID HL7 segment
  1. S ^PSX(550.1,PSXMSG,"T",2,0)="PID|||"_$P(VADM(2),"^")_"^"_(X1#11)_"^M11||"_$P(PSXNM,",")_"^"_$P(PSXNM,",",2)_"||||||"_VAPA(1)_"^"_VAPA(2)_"^"_VAPA(4)_"^"_$P($G(^DIC(5,+VAPA(5),0)),"^",2)_"^"_$P(VAPA(11),"^",2)
  1. ; Telephone #
  1. S XX=$$HLPHONE^HLFNC(VAPA(8)) S:XX["(" XX="("_$P(XX,"(",2,99)
  1. S $P(^PSX(550.1,PSXMSG,"T",2,0),"|",14)=XX
  1. ; Add other language flag
  1. S PSXLANG=$P($G(^PS(55,DFN,"LAN")),"^",2)
  1. I $G(PSXLANG)'>1 S PSXLANG=1
  1. I PSXLANG>1,'$P($G(^PS(55,DFN,"LAN")),"^") S PSXLANG=1 ; DON'T MARK AS SPANISH IF NO SPANISH SIG
  1. I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" S PSXLANG=$S(PSXLANG=1:"ENG",1:"SPA")
  1. S $P(^PSX(550.1,PSXMSG,"T",2,0),"|",15)=$G(PSXLANG) K PSXLANG
  1. S $P(^PSX(550.1,PSXMSG,"T",2,0),"|",18)=VA("PID") ;IHS/MSC/PLS 7/29/10
  1. ; GET PATIENT ICN - DON'T SEND IF LOCAL ICN ONLY
  1. ;IHS/MSC/PLS - 04/29/2013,10/24/2013 - Next five lines commented out
  1. ;S PSXICN=$$MPINODE^MPIFAPI(DFN) D
  1. ;.I PSXICN<0 S PSXICN="" Q
  1. ;.I $P(PSXICN,"^",4)=1 S PSXICN="" Q
  1. ;.S PSXICN=$P(PSXICN,"^")_"V"_$P(PSXICN,"^",2)
  1. ;S $P(^PSX(550.1,PSXMSG,"T",2,0),"|",18)=$G(PSXICN) K PSXICN
  1. S TDT=$P(VAPA(10),"^")
  1. I $G(VAPA(3))]""!($G(TDT)]"") D
  1. .I $G(TDT)>1 S TDT=TDT+17000000,TDT1=$E(TDT,1,4),TDT2=$E(TDT,5,6),TDT3=$E(TDT,7,8) S:TDT2'>0 TDT2="01" S:TDT3'>0 TDT3="01" S TDT=$G(TDT1)_$G(TDT2)_$G(TDT3)
  1. .S ^PSX(550.1,PSXMSG,"T",3,0)="NTE|8||"_$S($G(TDT)>1:"1\F\"_TDT_"\F\"_VAPA(3),1:"\F\\F\"_VAPA(3))
  1. K VADM,VAPA,X1,TDT,YT,TDT1,TDT2,TDT3
  1. Q
  1. LOADMSG ; set RXs HL7 text into PSXMSG 'T', set PSXBAT 1////1
  1. S PSX=3
  1. S X="" F Q:'$D(PSXORD("M")) S X=$O(PSXORD("M",X)) Q:'X S PSX=PSX+1 S ^PSX(550.1,PSXMSG,"T",PSX,0)=$G(PSXORD("M",X))
  1. K PSXORD("M"),X
  1. S X="" F Q:'$D(PSXORD("E")) S X=$O(PSXORD("E",X)) Q:'X S PSX=PSX+1 S ^PSX(550.1,PSXMSG,"T",PSX,0)=$G(PSXORD("E",X))
  1. K PSXORD("E"),X
  1. I '$D(PSXORD) Q ;PSX*2*33
  1. S X="" F S X=$O(PSXORD(X)) Q:'X S PSX=PSX+1 S ^PSX(550.1,PSXMSG,"T",PSX,0)=$G(PSXORD(X))
  1. S ^PSX(550.1,PSXMSG,"T",0)="^550.11A^"_PSX_"^"_PSX
  1. K X1,VAPA,VADM
  1. QMSG ;Queue message for transmission
  1. S DA=PSXMSG,DIE="^PSX(550.1," S DR="1////1" L +^PSX(550.1,DA):600
  1. D ^DIE L -^PSX(550.1,DA) K DA,DIE,DR,PSXORD
  1. Q
  1. ACKN ;Flag message as Acknowledged
  1. K BEG
  1. G LOGACK^PSXPURG
  1. PROC ;Flag message as Processed
  1. ;--------------------------------------------------------
  1. STAT ;Display status of CMOP RX QUEUE
  1. N X,PSX1,PSX2 S PSX1=$G(^PSX(550.1,0)) Q:PSX1=""
  1. S PSX1=+$P(PSX1,"^",3),PSX2=+$O(^PSX(550.1,"AS",0))
  1. W !!,"Next Order Number to Transmit : ",$S(PSX2:PSX2,1:PSX1)
  1. W !!,"Last Order Number Generated : ",PSX1
  1. Q
  1. SUSP ; put RXs ien int 550.1 RX multiple
  1. RXMSG ; put RX ien into 550.1 RX multiple , returns PSXRXMDA DA within 'M'essage multiple
  1. S:'$D(^PSX(550.1,PSXMSG,2,0)) ^PSX(550.1,PSXMSG,2,0)="^550.1101PA^^"
  1. SET ;
  1. K DD,DO,DIC
  1. S DA(1)=PSXMSG,(X,DA)=RX,DIC("DR")="1////"_RXF,DIC="^PSX(550.1,"_PSXMSG_",2,",DIC(0)="FZ"
  1. D FILE^DICN G:$P(Y,"^",3)'=1 SET K DA,X,DIC,DIC("DR")
  1. S PSXRXMDA=+Y
  1. Q
  1. STRIP(X) ;EP Strip control characters out and replace with " "
  1. ; $A(124) = Pipe Character '|'
  1. N I,Z
  1. F I=1:1:$L(X) S Z=$E(X,I),Z=$A(Z) I (Z<32)!(Z>126)!(Z=124) S X=$E(X,1,I-1)_" "_$E(X,I+1,999)
  1. Q X
  1. ;