PSOVDF1 ;BPOIFO/EL-OUTPATIENT PHARMACY (PRES, PREF, PPAR) HL7 MESSAGE ;10/04/04
;;7.0;OUTPATIENT PHARMACY;**190,205,220,235,261**;DEC 1997;Build 9
;
VALID ;;VDEF HL7 MESSAGE BUILDER
;
; DBIA #4248 - $$XCN200^VDEFEL (or <MultipleTag>^VDEFEL)
; DBIA #3552 - $$PARAM^HLCS2
; DBIA #3630 - BLDPID^VAFCQRY
; DBIA #10040 - 0-NODE of ^SC
; DBIA 4571 - ERR^VDEFREQ
;
; This routine is called at tag EN as a Function by VDEFREQ1
;
Q
;
EN(EVIEN,KEY,VFLAG,OUT,MSHP) ;
; This routine creates one of three Outpatient Pharmacy HL7 messages:
; RDE^O11^PRES, RDS^O13^PREF, or RDS^O13^PPAR
;
; Input Parameters:
; EVIEN - IEN of message in file 577
; KEY - IEN to File #52 ^PSRX
; VFLAG - "V" for VistA HL7 destination (default)
; OUT - Target array. Must be passed by reference
; MSHP - 4th piece is SUBTYPE (PRES, PREF, PPAR)
;
; Returns:
; Two piece string with separator '^':
; Piece 1 - "LM" - LOCAL ARRAY
; Piece 2 - MSH segment, is not set
; OUT - OUTPUT array includes HL7 message for every segment except MSH
;
; Message Body "MSH,PID,ORC1,RXE1,RXR1,FT1,OBX1,NTE1,ORC2,ORC3"
; The Pharmacy Original Fill message will be generated by pgm:PSOVDF2 - (ORC1. . NTE1)
;
;
N CTR,PSOVDFD0,PSOVDFD1,DFN,DRCODE,PSOVDRUG,ERR,FILE,FIELD,GIVECODE,GL,GLOB,GLOBAL,HLINST,PSOVDDIV,PSOVD59,PSOVERR
N I,L,MSG,NTE,P,RES,SEPC,SEPE,SEPF,SEPR,SEPS,SRC,SUBTYPE,TARGET,PSOVDFES,PSOVESC,PSOVDFIN
N HL7DEL,REPSEPC,REPSEPE,REPSEPF,REPSEPR,REPSEPS,TEMP,TP,UNIT,VAL,WR,X,Y,Z,VCMP,VFT7
;
S (ERR,TARGET)=""
D INIT
I $G(ERR)'="" D ERR^VDEFREQ(ERR) S ZTSTOP=1 G QUIT
D MSHPID
I $G(ERR)'="" D ERR^VDEFREQ(ERR) S ZTSTOP=1 G QUIT
D PROCESS^PSOVDF2
D ORC2
QUIT Q TARGET
;
INIT ;
K GL,OUT,TEMP,TP
S (PSOVDFD0,PSOVDFES,DFN,DRCODE,PSOVDRUG,FILE,GIVECODE,GLOB,SEPC,SEPE,SEPF,SEPR,SEPS,SRC,SUBTYPE,UNIT,VAL)=""
S (HL7DEL,REPSEPC,REPSEPE,REPSEPF,REPSEPR,REPSEPS)=""
S OUT("HLS")=0
S PSOVDFD0=KEY
I $G(U)'="^" S U="^"
S FILE=52
S SUBTYPE=$P($G(MSHP),"~",4)
S VAL=$G(HL("ECH")) I VAL="" S VAL="~|\&",HL("ECH")=VAL
S SEPE=$E(VAL,3),REPSEPE=SEPE_"E"_SEPE
S SEPC=$E(VAL,1),REPSEPC=SEPE_"S"_SEPE
S SEPR=$E(VAL,2),REPSEPR=SEPE_"R"_SEPE
S SEPS=$E(VAL,4),REPSEPS=SEPE_"T"_SEPE
S VAL=$G(HL("FS")) I VAL="" S VAL="^",HL("FS")=VAL
S SEPF=$E(VAL,1),REPSEPF=SEPE_"F"_SEPE
S HL7DEL=$G(HL("ECH"))_$G(HL("FS"))
S GLOB=$$ROOT^DILFD(FILE)_PSOVDFD0_")"
M GL=@GLOB
S DFN=$P($G(GL(0)),U,2)
I $G(DFN)="" S ERR="MISSING DFN IN FILE-52 AT IEN="_PSOVDFD0 Q
I $G(^DPT(DFN,0))="" S ERR="MISSING DFN IN FILE-2 AT FILE-52/IEN="_PSOVDFD0 Q
S PSOVDFES=$$REPL(PSOVDFD0)
S PSOVDFIN=$$SITE^VASITE,PSOVDFIN=$P($G(PSOVDFIN),"^",2),PSOVDFIN=$$REPL(PSOVDFIN)
Q
;
PUT(P) ; Put in MSG
I $G(VAL)="" Q
S $P(MSG,SEPF,P)=VAL
Q
;
REPL(L) ; REPLACE HL7 DELIMITER CHAR
I $G(L)="" Q ""
I $TR(L,$G(HL7DEL))=L Q L
N X,Y,Z,RES
S RES=L
I $F(L,SEPE) S X=RES D
. S Z=$P(X,SEPE,2,9999),Y=$P(X,SEPE)_REPSEPE_Z,RES=Y,X=Z I '$F(Z,SEPE) Q
. F I=2:1 S Z=$P(X,SEPE,2,9999),Y=$P(RES,REPSEPE,1,I-1)_REPSEPE_$P(X,SEPE)_REPSEPE_Z,RES=Y,X=Z I '$F(Z,SEPE) Q
I $F(RES,SEPC) F I=1:1 S Y=$P(RES,SEPC)_REPSEPC_$P(RES,SEPC,2,9999),RES=Y I '$F(RES,SEPC) Q
I $F(RES,SEPR) F I=1:1 S Y=$P(RES,SEPR)_REPSEPR_$P(RES,SEPR,2,9999),RES=Y I '$F(RES,SEPR) Q
I $F(RES,SEPS) F I=1:1 S Y=$P(RES,SEPS)_REPSEPS_$P(RES,SEPS,2,9999),RES=Y I '$F(RES,SEPS) Q
I $F(RES,SEPF) F I=1:1 S Y=$P(RES,SEPF)_REPSEPF_$P(RES,SEPF,2,9999),RES=Y I '$F(RES,SEPF) Q
Q RES
;
OUT D OUT^PSOVDF2 Q
OUT20 D OUT20^PSOVDF2 Q
;
MSHPID ;
MSH ; MSH
S (HLINST,MSG,SRC)=""
I '$D(SITEPARM) S SITEPARM=$$PARAM^HLCS2
S HLINST=$P(SITEPARM,U,6),HLINST=$$REPL(HLINST),SRC=HLINST_"_"_FILE
S TARGET="LM"_SEPF_MSG
;
PID ; PID
K WR
S (MSG)=""
D BLDPID^VAFCQRY(DFN,1,"",.WR,.HL,.ERR)
I $G(WR(1))="" S ERR="MISSING PID AT DFN="_DFN_" IN FILE-52 AT IEN="_PSOVDFD0 Q
I $P(WR(1),U,3)="V" S $P(WR(1),U,3)=""
D OUT20
K WR
Q
;
ORC2 ; RF
I '$D(GL(1)) G ORC3
K TEMP M TEMP=GL(1)
S PSOVDFD1=0
ORC2A S PSOVDFD1=$O(TEMP(PSOVDFD1)) G ORC3:'PSOVDFD1
S MSG=""
S TP=$G(TEMP(PSOVDFD1,0)) I TP="" G ORC2A
S PSOVESC=$$REPL(PSOVDFD1),VAL=PSOVESC D PUT(3)
; (7~4-10.1)
S (VAL,WR)="",WR=$P(TP,U,19) I $G(WR)'="" D
.S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL(WR),$P(VAL,SEPC,4)=WR,$P(VAL,SEPC,7)="DISPENSED"
; (7~5-13)
S WR=$P(TP,U,15) I $G(WR)'="" D
.S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL(WR),$P(VAL,SEPC,5)=WR,$P(VAL,SEPC,7)=$P(VAL,SEPC,7)_"/EXPIRATION"
D PUT(7)
S VAL="",$P(VAL,SEPC,2)=PSOVDFES D PUT(8)
; (9-7)
S VAL=$P(TP,U,8) I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL(VAL) D PUT(9)
; (12-15)
S VAL=$P(TP,U,17) I $G(VAL)'="" S VAL=$$XCN200^VDEFEL(VAL) D PUT(12)
S VAL="REFILL" D PUT(16)
S VAL=$P(TP,U,9) S:$G(VAL)="" VAL=$P($G(^PSRX(PSOVDFD0,2)),"^",9) I $G(VAL)'="" D
.S PSOVD59=VAL I $D(PSOVDDIV(VAL)) S VAL=$G(PSOVDDIV(VAL)) S $P(VAL,SEPC,3)=$P($P(VAL,SEPC,3),"_")_"_52.1_8" D PUT(17) Q
.N PSONCRF,PSONCRFP,PSOSTNUM
.S X=$G(^PS(59,VAL,0)),PSONCRFP=$P($G(^("SAND")),"^",3)
.S VAL=$P(X,U),(VAL,PSONCRF)=$$REPL(VAL) Q:VAL=""
.S PSOSTNUM=$P(X,U,6),PSOSTNUM=$$REPL(PSOSTNUM)
.S VAL=PSOSTNUM_SEPC_VAL_SEPC_HLINST_"_52.1_8"
.I PSONCRFP'="" S PSONCRFP=$$REPL(PSONCRFP),VAL=VAL_SEPC_PSONCRFP_SEPC_PSONCRF_SEPC_"NCPDP"
.S PSOVDDIV(PSOVD59)=$G(VAL)
.D PUT(17)
S VAL=$G(PSOVDFIN) D PUT(21)
I $D(VCMP(PSOVDFD1)) S VAL=SEPC_SEPC_SEPC_VCMP(PSOVDFD1) D PUT(25)
I $G(MSG)="" G ORC2Q
S $P(MSG,U)="RF"
S MSG="ORC"_SEPF_MSG D OUT
ORC2Q ; Q
;
RXE2 ; RF
S MSG=""
; (1~4-.01)
S (VAL,WR)="",WR=$P(TP,U,1) I $G(WR)'="" D
.S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL(WR),$P(VAL,SEPC,4)=WR,$P(VAL,SEPC,7)="REFILL" D PUT(1)
; (2~1..~3-6, 2~4-API , 2~6-NDC)
S VAL=""
I $T(NDC^PSOHDR)]"" D
.S VAL=$$NDC^PSOHDR(PSOVDFD0,PSOVDFD1,"R")
E S VAL=$P($G(TEMP(PSOVDFD1,1)),U,3) D
.I $G(VAL)="",$G(PSOVDRUG)'="" S VAL=$P($G(^PSDRUG(PSOVDRUG,2)),"^",4)
I $G(VAL)'="" D
.S VAL=$$REPL(VAL)
.S X="",X=GIVECODE,$P(X,SEPC,4)=VAL,$P(X,SEPC,6)="NDC",VAL=X D PUT(2)
E S VAL=GIVECODE D PUT(2)
S VAL=0 D PUT(3)
; (5-DEF="UNK" or API)
S VAL=UNIT D PUT(5)
; (8~6-2)
S (VAL,WR)=""
S WR=$$GET1^DIQ(52.1,PSOVDFD1_","_PSOVDFD0_",",2,"","","PSOVERR") K PSOVERR I $G(WR)'="" S WR=$$REPL(WR),$P(VAL,SEPC,6)=WR D PUT(8)
; (10-1)
S VAL=$P(TP,U,4),VAL=$$REPL(VAL) D PUT(10)
; (14|1-4)
S VAL=$P(TP,U,5) I $G(VAL)="" G RXE2A
S VAL=$$XCN200^VDEFEL(VAL,"PHARMACIST") D PUT(14)
; (18-17)
RXE2A S VAL=$P(TP,U,18) I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL(VAL) D PUT(18)
; (22-1.1)
S VAL=$P(TP,U,10) I $G(VAL)'="" S VAL="D"_VAL,VAL=$$REPL(VAL) D PUT(22)
D RXE31A^PSOVDF3
D PUT(31)
I $G(MSG)="" G RXE2Q
S MSG="RXE"_SEPF_MSG D OUT
RXE2Q ; Q
;
NTE2 ; RF
S MSG=""
; (3-52.1_3)
S WR=$P(TP,U,3) I $G(WR)="" G NTE2Q
S VAL=PSOVDFD1 D PUT(1)
S VAL=$$REPL(WR)
D PUT(3),RREM^PSOVDF3,PUT(4)
S MSG="NTE"_SEPF_MSG D OUT
NTE2Q ; Q
;
FT12 ; RF
; patch 261 - FT1
D FT1R^PSOVDF3
FT12Q ; Q
G ORC2A
;
ORC3 ; PAR
I '$D(GL("P")) Q
K TEMP M TEMP=GL("P")
S PSOVDFD1=0
ORC3A S PSOVDFD1=$O(TEMP(PSOVDFD1)) Q:'PSOVDFD1
S MSG=""
S TP=$G(TEMP(PSOVDFD1,0)) I TP="" G ORC3A
S PSOVESC=$$REPL(PSOVDFD1),VAL=PSOVESC D PUT(3)
; (7~4-7.5)
S WR=$P(TP,U,13) I $G(WR)'="" D
.S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL(WR),VAL="",$P(VAL,SEPC,4)=WR,$P(VAL,SEPC,7)="DISPENSED" D PUT(7)
S VAL="",$P(VAL,SEPC,2)=PSOVDFES D PUT(8)
; (9-.08)
S VAL=$P(TP,U,8) I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL(VAL) D PUT(9)
; (12-6)
S VAL=$P(TP,U,17) I $G(VAL)'="" S VAL=$$XCN200^VDEFEL(VAL) D PUT(12)
S VAL="PARTIAL" D PUT(16)
S VAL=$P(TP,U,9) S:$G(VAL)="" VAL=$P($G(^PSRX(PSOVDFD0,2)),"^",9) I $G(VAL)'="" D
.S PSOVD59=VAL I $D(PSOVDDIV(VAL)) S VAL=$G(PSOVDDIV(VAL)) S $P(VAL,SEPC,3)=$P($P(VAL,SEPC,3),"_")_"_52.2_.09" D PUT(17) Q
.N PSONCPR,PSONCPRP,PSOSPNUM
.S X=$G(^PS(59,VAL,0)),PSONCPRP=$P($G(^("SAND")),"^",3)
.S VAL=$P(X,U),(VAL,PSONCPR)=$$REPL(VAL) Q:VAL=""
.S PSOSPNUM=$P(X,U,6),PSOSPNUM=$$REPL(PSOSPNUM)
.S VAL=PSOSPNUM_SEPC_VAL_SEPC_HLINST_"_52.2_.09"
.I PSONCPRP'="" S PSONCPRP=$$REPL(PSONCPRP),VAL=VAL_SEPC_PSONCPRP_SEPC_PSONCPR_SEPC_"NCPDP"
.S PSOVDDIV(PSOVD59)=$G(VAL)
.D PUT(17)
S VAL=$G(PSOVDFIN) D PUT(21)
I $G(MSG)="" G ORC3Q
S $P(MSG,U)="RF"
S MSG="ORC"_SEPF_MSG D OUT
ORC3Q ; Q
;
RXE3 ; PAR
S MSG=""
; (1~4-.01)
S WR=$P(TP,U,1) I $G(WR)'="" D
.S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL(WR),VAL="",$P(VAL,SEPC,4)=WR,$P(VAL,SEPC,7)="PARTIAL" D PUT(1)
; (2~1..~3-6, 2~4-API, 2~6-NDC)
S VAL=""
I $T(NDC^PSOHDR)]"" D
.S VAL=$$NDC^PSOHDR(PSOVDFD0,PSOVDFD1,"P")
E S VAL=$P($G(TEMP(PSOVDFD1,0)),U,12) D
.I $G(VAL)="",$G(PSOVDRUG)'="" S VAL=$P($G(^PSDRUG(PSOVDRUG,2)),"^",4)
I $G(VAL)'="" D
.S VAL=$$REPL(VAL)
.S X="",X=GIVECODE,$P(X,SEPC,4)=VAL,$P(X,SEPC,6)="NDC",VAL=X D PUT(2)
E S VAL=GIVECODE D PUT(2)
S VAL=0 D PUT(3)
; (5-DEF="UNK" or API)
S VAL=UNIT D PUT(5)
; (8~6-.02)
S (VAL,WR)=""
S WR=$$GET1^DIQ(52.2,PSOVDFD1_","_PSOVDFD0_",",.02,"","","PSOVERR") K PSOVERR I $G(WR)'="" S WR=$$REPL(WR),$P(VAL,SEPC,6)=WR D PUT(8)
; (10-.04)
S VAL=$P(TP,U,4),VAL=$$REPL(VAL) D PUT(10)
; (14|1-.05)
S VAL=$P(TP,U,5) I $G(VAL)="" G RXE3B
S VAL=$$XCN200^VDEFEL(VAL,"PHARMACIST") D PUT(14)
; (18-8)
RXE3B S VAL=$P(TP,U,19) I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL(VAL) D PUT(18)
S VAL=$P(TP,U,10) I $G(VAL)'="" S VAL="D"_VAL,VAL=$$REPL(VAL) D PUT(22)
D RXE31^PSOVDF3
D PUT(31)
;
I $G(MSG)="" G RXE3Q
S MSG="RXE"_SEPF_MSG D OUT
RXE3Q ; Q
;
NTE3 ; PAR
S MSG=""
; (3-.03)
S WR=$P(TP,U,3) I $G(WR)="" G NTE3Q
S VAL=PSOVDFD1 D PUT(1)
S VAL=$$REPL(WR)
D PUT(3),PREM^PSOVDF3,PUT(4)
S MSG="NTE"_SEPF_MSG D OUT
NTE3Q ; Q
FT13 ; patch 261
D FT1R^PSOVDF3
G ORC3A
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOVDF1 9971 printed Apr 09, 2024@21:32:31 Page 2
PSOVDF1 ;BPOIFO/EL-OUTPATIENT PHARMACY (PRES, PREF, PPAR) HL7 MESSAGE ;10/04/04
+1 ;;7.0;OUTPATIENT PHARMACY;**190,205,220,235,261**;DEC 1997;Build 9
+2 ;
VALID ;;VDEF HL7 MESSAGE BUILDER
+1 ;
+2 ; DBIA #4248 - $$XCN200^VDEFEL (or <MultipleTag>^VDEFEL)
+3 ; DBIA #3552 - $$PARAM^HLCS2
+4 ; DBIA #3630 - BLDPID^VAFCQRY
+5 ; DBIA #10040 - 0-NODE of ^SC
+6 ; DBIA 4571 - ERR^VDEFREQ
+7 ;
+8 ; This routine is called at tag EN as a Function by VDEFREQ1
+9 ;
+10 QUIT
+11 ;
EN(EVIEN,KEY,VFLAG,OUT,MSHP) ;
+1 ; This routine creates one of three Outpatient Pharmacy HL7 messages:
+2 ; RDE^O11^PRES, RDS^O13^PREF, or RDS^O13^PPAR
+3 ;
+4 ; Input Parameters:
+5 ; EVIEN - IEN of message in file 577
+6 ; KEY - IEN to File #52 ^PSRX
+7 ; VFLAG - "V" for VistA HL7 destination (default)
+8 ; OUT - Target array. Must be passed by reference
+9 ; MSHP - 4th piece is SUBTYPE (PRES, PREF, PPAR)
+10 ;
+11 ; Returns:
+12 ; Two piece string with separator '^':
+13 ; Piece 1 - "LM" - LOCAL ARRAY
+14 ; Piece 2 - MSH segment, is not set
+15 ; OUT - OUTPUT array includes HL7 message for every segment except MSH
+16 ;
+17 ; Message Body "MSH,PID,ORC1,RXE1,RXR1,FT1,OBX1,NTE1,ORC2,ORC3"
+18 ; The Pharmacy Original Fill message will be generated by pgm:PSOVDF2 - (ORC1. . NTE1)
+19 ;
+20 ;
+21 NEW CTR,PSOVDFD0,PSOVDFD1,DFN,DRCODE,PSOVDRUG,ERR,FILE,FIELD,GIVECODE,GL,GLOB,GLOBAL,HLINST,PSOVDDIV,PSOVD59,PSOVERR
+22 NEW I,L,MSG,NTE,P,RES,SEPC,SEPE,SEPF,SEPR,SEPS,SRC,SUBTYPE,TARGET,PSOVDFES,PSOVESC,PSOVDFIN
+23 NEW HL7DEL,REPSEPC,REPSEPE,REPSEPF,REPSEPR,REPSEPS,TEMP,TP,UNIT,VAL,WR,X,Y,Z,VCMP,VFT7
+24 ;
+25 SET (ERR,TARGET)=""
+26 DO INIT
+27 IF $GET(ERR)'=""
DO ERR^VDEFREQ(ERR)
SET ZTSTOP=1
GOTO QUIT
+28 DO MSHPID
+29 IF $GET(ERR)'=""
DO ERR^VDEFREQ(ERR)
SET ZTSTOP=1
GOTO QUIT
+30 DO PROCESS^PSOVDF2
+31 DO ORC2
QUIT QUIT TARGET
+1 ;
INIT ;
+1 KILL GL,OUT,TEMP,TP
+2 SET (PSOVDFD0,PSOVDFES,DFN,DRCODE,PSOVDRUG,FILE,GIVECODE,GLOB,SEPC,SEPE,SEPF,SEPR,SEPS,SRC,SUBTYPE,UNIT,VAL)=""
+3 SET (HL7DEL,REPSEPC,REPSEPE,REPSEPF,REPSEPR,REPSEPS)=""
+4 SET OUT("HLS")=0
+5 SET PSOVDFD0=KEY
+6 IF $GET(U)'="^"
SET U="^"
+7 SET FILE=52
+8 SET SUBTYPE=$PIECE($GET(MSHP),"~",4)
+9 SET VAL=$GET(HL("ECH"))
IF VAL=""
SET VAL="~|\&"
SET HL("ECH")=VAL
+10 SET SEPE=$EXTRACT(VAL,3)
SET REPSEPE=SEPE_"E"_SEPE
+11 SET SEPC=$EXTRACT(VAL,1)
SET REPSEPC=SEPE_"S"_SEPE
+12 SET SEPR=$EXTRACT(VAL,2)
SET REPSEPR=SEPE_"R"_SEPE
+13 SET SEPS=$EXTRACT(VAL,4)
SET REPSEPS=SEPE_"T"_SEPE
+14 SET VAL=$GET(HL("FS"))
IF VAL=""
SET VAL="^"
SET HL("FS")=VAL
+15 SET SEPF=$EXTRACT(VAL,1)
SET REPSEPF=SEPE_"F"_SEPE
+16 SET HL7DEL=$GET(HL("ECH"))_$GET(HL("FS"))
+17 SET GLOB=$$ROOT^DILFD(FILE)_PSOVDFD0_")"
+18 MERGE GL=@GLOB
+19 SET DFN=$PIECE($GET(GL(0)),U,2)
+20 IF $GET(DFN)=""
SET ERR="MISSING DFN IN FILE-52 AT IEN="_PSOVDFD0
QUIT
+21 IF $GET(^DPT(DFN,0))=""
SET ERR="MISSING DFN IN FILE-2 AT FILE-52/IEN="_PSOVDFD0
QUIT
+22 SET PSOVDFES=$$REPL(PSOVDFD0)
+23 SET PSOVDFIN=$$SITE^VASITE
SET PSOVDFIN=$PIECE($GET(PSOVDFIN),"^",2)
SET PSOVDFIN=$$REPL(PSOVDFIN)
+24 QUIT
+25 ;
PUT(P) ; Put in MSG
+1 IF $GET(VAL)=""
QUIT
+2 SET $PIECE(MSG,SEPF,P)=VAL
+3 QUIT
+4 ;
REPL(L) ; REPLACE HL7 DELIMITER CHAR
+1 IF $GET(L)=""
QUIT ""
+2 IF $TRANSLATE(L,$GET(HL7DEL))=L
QUIT L
+3 NEW X,Y,Z,RES
+4 SET RES=L
+5 IF $FIND(L,SEPE)
SET X=RES
Begin DoDot:1
+6 SET Z=$PIECE(X,SEPE,2,9999)
SET Y=$PIECE(X,SEPE)_REPSEPE_Z
SET RES=Y
SET X=Z
IF '$FIND(Z,SEPE)
QUIT
+7 FOR I=2:1
SET Z=$PIECE(X,SEPE,2,9999)
SET Y=$PIECE(RES,REPSEPE,1,I-1)_REPSEPE_$PIECE(X,SEPE)_REPSEPE_Z
SET RES=Y
SET X=Z
IF '$FIND(Z,SEPE)
QUIT
End DoDot:1
+8 IF $FIND(RES,SEPC)
FOR I=1:1
SET Y=$PIECE(RES,SEPC)_REPSEPC_$PIECE(RES,SEPC,2,9999)
SET RES=Y
IF '$FIND(RES,SEPC)
QUIT
+9 IF $FIND(RES,SEPR)
FOR I=1:1
SET Y=$PIECE(RES,SEPR)_REPSEPR_$PIECE(RES,SEPR,2,9999)
SET RES=Y
IF '$FIND(RES,SEPR)
QUIT
+10 IF $FIND(RES,SEPS)
FOR I=1:1
SET Y=$PIECE(RES,SEPS)_REPSEPS_$PIECE(RES,SEPS,2,9999)
SET RES=Y
IF '$FIND(RES,SEPS)
QUIT
+11 IF $FIND(RES,SEPF)
FOR I=1:1
SET Y=$PIECE(RES,SEPF)_REPSEPF_$PIECE(RES,SEPF,2,9999)
SET RES=Y
IF '$FIND(RES,SEPF)
QUIT
+12 QUIT RES
+13 ;
OUT DO OUT^PSOVDF2
QUIT
OUT20 DO OUT20^PSOVDF2
QUIT
+1 ;
MSHPID ;
MSH ; MSH
+1 SET (HLINST,MSG,SRC)=""
+2 IF '$DATA(SITEPARM)
SET SITEPARM=$$PARAM^HLCS2
+3 SET HLINST=$PIECE(SITEPARM,U,6)
SET HLINST=$$REPL(HLINST)
SET SRC=HLINST_"_"_FILE
+4 SET TARGET="LM"_SEPF_MSG
+5 ;
PID ; PID
+1 KILL WR
+2 SET (MSG)=""
+3 DO BLDPID^VAFCQRY(DFN,1,"",.WR,.HL,.ERR)
+4 IF $GET(WR(1))=""
SET ERR="MISSING PID AT DFN="_DFN_" IN FILE-52 AT IEN="_PSOVDFD0
QUIT
+5 IF $PIECE(WR(1),U,3)="V"
SET $PIECE(WR(1),U,3)=""
+6 DO OUT20
+7 KILL WR
+8 QUIT
+9 ;
ORC2 ; RF
+1 IF '$DATA(GL(1))
GOTO ORC3
+2 KILL TEMP
MERGE TEMP=GL(1)
+3 SET PSOVDFD1=0
ORC2A SET PSOVDFD1=$ORDER(TEMP(PSOVDFD1))
if 'PSOVDFD1
GOTO ORC3
+1 SET MSG=""
+2 SET TP=$GET(TEMP(PSOVDFD1,0))
IF TP=""
GOTO ORC2A
+3 SET PSOVESC=$$REPL(PSOVDFD1)
SET VAL=PSOVESC
DO PUT(3)
+4 ; (7~4-10.1)
+5 SET (VAL,WR)=""
SET WR=$PIECE(TP,U,19)
IF $GET(WR)'=""
Begin DoDot:1
+6 SET WR=$$HLDATE^HLFNC(WR,"TS")
IF WR>0
SET WR=$$REPL(WR)
SET $PIECE(VAL,SEPC,4)=WR
SET $PIECE(VAL,SEPC,7)="DISPENSED"
End DoDot:1
+7 ; (7~5-13)
+8 SET WR=$PIECE(TP,U,15)
IF $GET(WR)'=""
Begin DoDot:1
+9 SET WR=$$HLDATE^HLFNC(WR,"TS")
IF WR>0
SET WR=$$REPL(WR)
SET $PIECE(VAL,SEPC,5)=WR
SET $PIECE(VAL,SEPC,7)=$PIECE(VAL,SEPC,7)_"/EXPIRATION"
End DoDot:1
+10 DO PUT(7)
+11 SET VAL=""
SET $PIECE(VAL,SEPC,2)=PSOVDFES
DO PUT(8)
+12 ; (9-7)
+13 SET VAL=$PIECE(TP,U,8)
IF $GET(VAL)'=""
SET VAL=$$HLDATE^HLFNC(VAL,"TS")
IF VAL>0
SET VAL=$$REPL(VAL)
DO PUT(9)
+14 ; (12-15)
+15 SET VAL=$PIECE(TP,U,17)
IF $GET(VAL)'=""
SET VAL=$$XCN200^VDEFEL(VAL)
DO PUT(12)
+16 SET VAL="REFILL"
DO PUT(16)
+17 SET VAL=$PIECE(TP,U,9)
if $GET(VAL)=""
SET VAL=$PIECE($GET(^PSRX(PSOVDFD0,2)),"^",9)
IF $GET(VAL)'=""
Begin DoDot:1
+18 SET PSOVD59=VAL
IF $DATA(PSOVDDIV(VAL))
SET VAL=$GET(PSOVDDIV(VAL))
SET $PIECE(VAL,SEPC,3)=$PIECE($PIECE(VAL,SEPC,3),"_")_"_52.1_8"
DO PUT(17)
QUIT
+19 NEW PSONCRF,PSONCRFP,PSOSTNUM
+20 SET X=$GET(^PS(59,VAL,0))
SET PSONCRFP=$PIECE($GET(^("SAND")),"^",3)
+21 SET VAL=$PIECE(X,U)
SET (VAL,PSONCRF)=$$REPL(VAL)
if VAL=""
QUIT
+22 SET PSOSTNUM=$PIECE(X,U,6)
SET PSOSTNUM=$$REPL(PSOSTNUM)
+23 SET VAL=PSOSTNUM_SEPC_VAL_SEPC_HLINST_"_52.1_8"
+24 IF PSONCRFP'=""
SET PSONCRFP=$$REPL(PSONCRFP)
SET VAL=VAL_SEPC_PSONCRFP_SEPC_PSONCRF_SEPC_"NCPDP"
+25 SET PSOVDDIV(PSOVD59)=$GET(VAL)
+26 DO PUT(17)
End DoDot:1
+27 SET VAL=$GET(PSOVDFIN)
DO PUT(21)
+28 IF $DATA(VCMP(PSOVDFD1))
SET VAL=SEPC_SEPC_SEPC_VCMP(PSOVDFD1)
DO PUT(25)
+29 IF $GET(MSG)=""
GOTO ORC2Q
+30 SET $PIECE(MSG,U)="RF"
+31 SET MSG="ORC"_SEPF_MSG
DO OUT
ORC2Q ; Q
+1 ;
RXE2 ; RF
+1 SET MSG=""
+2 ; (1~4-.01)
+3 SET (VAL,WR)=""
SET WR=$PIECE(TP,U,1)
IF $GET(WR)'=""
Begin DoDot:1
+4 SET WR=$$HLDATE^HLFNC(WR,"TS")
IF WR>0
SET WR=$$REPL(WR)
SET $PIECE(VAL,SEPC,4)=WR
SET $PIECE(VAL,SEPC,7)="REFILL"
DO PUT(1)
End DoDot:1
+5 ; (2~1..~3-6, 2~4-API , 2~6-NDC)
+6 SET VAL=""
+7 IF $TEXT(NDC^PSOHDR)]""
Begin DoDot:1
+8 SET VAL=$$NDC^PSOHDR(PSOVDFD0,PSOVDFD1,"R")
End DoDot:1
+9 IF '$TEST
SET VAL=$PIECE($GET(TEMP(PSOVDFD1,1)),U,3)
Begin DoDot:1
+10 IF $GET(VAL)=""
IF $GET(PSOVDRUG)'=""
SET VAL=$PIECE($GET(^PSDRUG(PSOVDRUG,2)),"^",4)
End DoDot:1
+11 IF $GET(VAL)'=""
Begin DoDot:1
+12 SET VAL=$$REPL(VAL)
+13 SET X=""
SET X=GIVECODE
SET $PIECE(X,SEPC,4)=VAL
SET $PIECE(X,SEPC,6)="NDC"
SET VAL=X
DO PUT(2)
End DoDot:1
+14 IF '$TEST
SET VAL=GIVECODE
DO PUT(2)
+15 SET VAL=0
DO PUT(3)
+16 ; (5-DEF="UNK" or API)
+17 SET VAL=UNIT
DO PUT(5)
+18 ; (8~6-2)
+19 SET (VAL,WR)=""
+20 SET WR=$$GET1^DIQ(52.1,PSOVDFD1_","_PSOVDFD0_",",2,"","","PSOVERR")
KILL PSOVERR
IF $GET(WR)'=""
SET WR=$$REPL(WR)
SET $PIECE(VAL,SEPC,6)=WR
DO PUT(8)
+21 ; (10-1)
+22 SET VAL=$PIECE(TP,U,4)
SET VAL=$$REPL(VAL)
DO PUT(10)
+23 ; (14|1-4)
+24 SET VAL=$PIECE(TP,U,5)
IF $GET(VAL)=""
GOTO RXE2A
+25 SET VAL=$$XCN200^VDEFEL(VAL,"PHARMACIST")
DO PUT(14)
+26 ; (18-17)
RXE2A SET VAL=$PIECE(TP,U,18)
IF $GET(VAL)'=""
SET VAL=$$HLDATE^HLFNC(VAL,"TS")
IF VAL>0
SET VAL=$$REPL(VAL)
DO PUT(18)
+1 ; (22-1.1)
+2 SET VAL=$PIECE(TP,U,10)
IF $GET(VAL)'=""
SET VAL="D"_VAL
SET VAL=$$REPL(VAL)
DO PUT(22)
+3 DO RXE31A^PSOVDF3
+4 DO PUT(31)
+5 IF $GET(MSG)=""
GOTO RXE2Q
+6 SET MSG="RXE"_SEPF_MSG
DO OUT
RXE2Q ; Q
+1 ;
NTE2 ; RF
+1 SET MSG=""
+2 ; (3-52.1_3)
+3 SET WR=$PIECE(TP,U,3)
IF $GET(WR)=""
GOTO NTE2Q
+4 SET VAL=PSOVDFD1
DO PUT(1)
+5 SET VAL=$$REPL(WR)
+6 DO PUT(3)
DO RREM^PSOVDF3
DO PUT(4)
+7 SET MSG="NTE"_SEPF_MSG
DO OUT
NTE2Q ; Q
+1 ;
FT12 ; RF
+1 ; patch 261 - FT1
+2 DO FT1R^PSOVDF3
FT12Q ; Q
+1 GOTO ORC2A
+2 ;
ORC3 ; PAR
+1 IF '$DATA(GL("P"))
QUIT
+2 KILL TEMP
MERGE TEMP=GL("P")
+3 SET PSOVDFD1=0
ORC3A SET PSOVDFD1=$ORDER(TEMP(PSOVDFD1))
if 'PSOVDFD1
QUIT
+1 SET MSG=""
+2 SET TP=$GET(TEMP(PSOVDFD1,0))
IF TP=""
GOTO ORC3A
+3 SET PSOVESC=$$REPL(PSOVDFD1)
SET VAL=PSOVESC
DO PUT(3)
+4 ; (7~4-7.5)
+5 SET WR=$PIECE(TP,U,13)
IF $GET(WR)'=""
Begin DoDot:1
+6 SET WR=$$HLDATE^HLFNC(WR,"TS")
IF WR>0
SET WR=$$REPL(WR)
SET VAL=""
SET $PIECE(VAL,SEPC,4)=WR
SET $PIECE(VAL,SEPC,7)="DISPENSED"
DO PUT(7)
End DoDot:1
+7 SET VAL=""
SET $PIECE(VAL,SEPC,2)=PSOVDFES
DO PUT(8)
+8 ; (9-.08)
+9 SET VAL=$PIECE(TP,U,8)
IF $GET(VAL)'=""
SET VAL=$$HLDATE^HLFNC(VAL,"TS")
IF VAL>0
SET VAL=$$REPL(VAL)
DO PUT(9)
+10 ; (12-6)
+11 SET VAL=$PIECE(TP,U,17)
IF $GET(VAL)'=""
SET VAL=$$XCN200^VDEFEL(VAL)
DO PUT(12)
+12 SET VAL="PARTIAL"
DO PUT(16)
+13 SET VAL=$PIECE(TP,U,9)
if $GET(VAL)=""
SET VAL=$PIECE($GET(^PSRX(PSOVDFD0,2)),"^",9)
IF $GET(VAL)'=""
Begin DoDot:1
+14 SET PSOVD59=VAL
IF $DATA(PSOVDDIV(VAL))
SET VAL=$GET(PSOVDDIV(VAL))
SET $PIECE(VAL,SEPC,3)=$PIECE($PIECE(VAL,SEPC,3),"_")_"_52.2_.09"
DO PUT(17)
QUIT
+15 NEW PSONCPR,PSONCPRP,PSOSPNUM
+16 SET X=$GET(^PS(59,VAL,0))
SET PSONCPRP=$PIECE($GET(^("SAND")),"^",3)
+17 SET VAL=$PIECE(X,U)
SET (VAL,PSONCPR)=$$REPL(VAL)
if VAL=""
QUIT
+18 SET PSOSPNUM=$PIECE(X,U,6)
SET PSOSPNUM=$$REPL(PSOSPNUM)
+19 SET VAL=PSOSPNUM_SEPC_VAL_SEPC_HLINST_"_52.2_.09"
+20 IF PSONCPRP'=""
SET PSONCPRP=$$REPL(PSONCPRP)
SET VAL=VAL_SEPC_PSONCPRP_SEPC_PSONCPR_SEPC_"NCPDP"
+21 SET PSOVDDIV(PSOVD59)=$GET(VAL)
+22 DO PUT(17)
End DoDot:1
+23 SET VAL=$GET(PSOVDFIN)
DO PUT(21)
+24 IF $GET(MSG)=""
GOTO ORC3Q
+25 SET $PIECE(MSG,U)="RF"
+26 SET MSG="ORC"_SEPF_MSG
DO OUT
ORC3Q ; Q
+1 ;
RXE3 ; PAR
+1 SET MSG=""
+2 ; (1~4-.01)
+3 SET WR=$PIECE(TP,U,1)
IF $GET(WR)'=""
Begin DoDot:1
+4 SET WR=$$HLDATE^HLFNC(WR,"TS")
IF WR>0
SET WR=$$REPL(WR)
SET VAL=""
SET $PIECE(VAL,SEPC,4)=WR
SET $PIECE(VAL,SEPC,7)="PARTIAL"
DO PUT(1)
End DoDot:1
+5 ; (2~1..~3-6, 2~4-API, 2~6-NDC)
+6 SET VAL=""
+7 IF $TEXT(NDC^PSOHDR)]""
Begin DoDot:1
+8 SET VAL=$$NDC^PSOHDR(PSOVDFD0,PSOVDFD1,"P")
End DoDot:1
+9 IF '$TEST
SET VAL=$PIECE($GET(TEMP(PSOVDFD1,0)),U,12)
Begin DoDot:1
+10 IF $GET(VAL)=""
IF $GET(PSOVDRUG)'=""
SET VAL=$PIECE($GET(^PSDRUG(PSOVDRUG,2)),"^",4)
End DoDot:1
+11 IF $GET(VAL)'=""
Begin DoDot:1
+12 SET VAL=$$REPL(VAL)
+13 SET X=""
SET X=GIVECODE
SET $PIECE(X,SEPC,4)=VAL
SET $PIECE(X,SEPC,6)="NDC"
SET VAL=X
DO PUT(2)
End DoDot:1
+14 IF '$TEST
SET VAL=GIVECODE
DO PUT(2)
+15 SET VAL=0
DO PUT(3)
+16 ; (5-DEF="UNK" or API)
+17 SET VAL=UNIT
DO PUT(5)
+18 ; (8~6-.02)
+19 SET (VAL,WR)=""
+20 SET WR=$$GET1^DIQ(52.2,PSOVDFD1_","_PSOVDFD0_",",.02,"","","PSOVERR")
KILL PSOVERR
IF $GET(WR)'=""
SET WR=$$REPL(WR)
SET $PIECE(VAL,SEPC,6)=WR
DO PUT(8)
+21 ; (10-.04)
+22 SET VAL=$PIECE(TP,U,4)
SET VAL=$$REPL(VAL)
DO PUT(10)
+23 ; (14|1-.05)
+24 SET VAL=$PIECE(TP,U,5)
IF $GET(VAL)=""
GOTO RXE3B
+25 SET VAL=$$XCN200^VDEFEL(VAL,"PHARMACIST")
DO PUT(14)
+26 ; (18-8)
RXE3B SET VAL=$PIECE(TP,U,19)
IF $GET(VAL)'=""
SET VAL=$$HLDATE^HLFNC(VAL,"TS")
IF VAL>0
SET VAL=$$REPL(VAL)
DO PUT(18)
+1 SET VAL=$PIECE(TP,U,10)
IF $GET(VAL)'=""
SET VAL="D"_VAL
SET VAL=$$REPL(VAL)
DO PUT(22)
+2 DO RXE31^PSOVDF3
+3 DO PUT(31)
+4 ;
+5 IF $GET(MSG)=""
GOTO RXE3Q
+6 SET MSG="RXE"_SEPF_MSG
DO OUT
RXE3Q ; Q
+1 ;
NTE3 ; PAR
+1 SET MSG=""
+2 ; (3-.03)
+3 SET WR=$PIECE(TP,U,3)
IF $GET(WR)=""
GOTO NTE3Q
+4 SET VAL=PSOVDFD1
DO PUT(1)
+5 SET VAL=$$REPL(WR)
+6 DO PUT(3)
DO PREM^PSOVDF3
DO PUT(4)
+7 SET MSG="NTE"_SEPF_MSG
DO OUT
NTE3Q ; Q
FT13 ; patch 261
+1 DO FT1R^PSOVDF3
+2 GOTO ORC3A
+3 ;
+4 QUIT
