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