- 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 Feb 19, 2025@00:02:40 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