- PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94
- ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121,292**;DEC 1997;Build 1
- ;Externel reference EN^ORERR supported by DBIA 2187
- ;
- ; PS EVSEND OR PROTOCOL MUST BE OUR DRIVER RTN, (52 OR 52.41 INDICATOR
- ; IS SENT THERE, THEN IT ROUTES, (NO NEED TO SEND FILE NUMBER HERE)
- EN(PLACER,STAT,COMM,PSNOO) ;
- N DA,FIELD,J,JJ,MSG,LIMIT,NULLFLDS,PSIEN,PSOHINST,PSZERO,SEGMENT,NAME,DFN,COUNT,GG,CC,CT,MM,PVAR,PVAR1,PLIM,SEG1,SUBCOUNT,PSOPSTRT,PSOPSTOP,PSODFN,EDUZ,PSNOOTX,PSOHSTAT,PSOPSIEN
- S (PSIEN,PSOPSIEN)=$O(^PS(52.41,"B",PLACER,0))
- S COUNT=0
- ;I '$G(PSIEN) W !!,?5,"PROBLEM WITH ENTRY IN PENDING FILE!",! Q
- I '$G(PSIEN) Q
- I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D
- .D CHKOLDRX
- .I $D(^PS(52.41,PSIEN,0)) K ^PS(52.41,"AD",$P(^PS(52.41,PSIEN,0),"^",12),+$P($G(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$P(^PS(52.41,PSIEN,0),"^",13),+$P(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSIEN,0)),"^",21),PSIEN)
- S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT)
- S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
- D INIT
- I $G(STAT)="Z@" S COUNT=1 D PID,PV1,ORC,SEND Q
- S COUNT=1 D PID,PV1,ORC,RXE,ZRX,SEND,REN Q
- INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
- S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM")
- Q
- PID S LIMIT=5 X NULLFLDS
- S FIELD(0)="PID"
- S DFN=+$P(PSZERO,"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM
- S FIELD(3)=DFN
- S FIELD(5)=NAME
- D SEG Q
- PV1 S LIMIT=19 X NULLFLDS
- S FIELD(0)="PV1"
- S FIELD(2)="O"
- S:$P($G(^PS(52.41,PSIEN,0)),"^",13) FIELD(3)=$P(^(0),"^",13)
- D SEG Q
- ORC S LIMIT=15 X NULLFLDS
- S FIELD(0)="ORC"
- S FIELD(1)=STAT
- S FIELD(2)=PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"
- S FIELD(3)=PSIEN_"S"_"^PS"
- I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="IP"
- S:$G(COMM)="IP" FIELD(5)="IP"
- I $G(STAT)="SC" S FIELD(5)=$S($G(COMM)="IP":"IP",$G(COMM)="HD":"HD",$G(COMM)="DC":"DC",1:"")
- I $G(PSORPV),$G(STAT)="OC" S FIELD(5)="RP"
- ;S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
- ;I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
- ;.S DT=$$DT^XLFDT
- ;K X S FIELD(7)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
- S EDUZ=$P($G(^PS(52.41,PSIEN,0)),"^",4) I EDUZ D USER^PSOORFI2(EDUZ) S FIELD(10)=EDUZ_"^"_USER1 K USER1
- I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OC"!($G(STAT)="OD") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN)
- I '$G(FIELD(12)) D USER^PSOORFI2($P(^PS(52.41,PSIEN,0),"^",5))
- I '$G(FIELD(12)) S FIELD(12)=$P(^PS(52.41,PSIEN,0),"^",5)_"^"_USER1 K USER1
- S FIELD(15)=$G(PSOPSTRT)
- D SEG
- I $G(COMM)'=""!($G(PSNOO)'="") D
- .I $G(PSNOO)="" I $G(COMM)="IP"!($G(COMM)="HD")!($G(COMM)="DC") Q
- .I $G(PSNOO)'="" D NOO^PSOHLSN1
- .I '$D(COMM) S COMM=""
- .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q
- .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q
- Q
- RXE S LIMIT=1 X NULLFLDS
- S FIELD(0)="RXE"
- S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
- I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
- .S DT=$$DT^XLFDT
- K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
- D SEG Q
- ;
- ZRX ;
- ;Only send if DC is from an external system
- I $G(STAT)'="OC",$G(STAT)'="OD" Q
- I '$G(PSOHUIOR)!('$G(PSOCANRC)) Q
- I $P($G(^PS(52.41,PSIEN,"EXT")),"^")="" Q
- S LIMIT=5 X NULLFLDS
- S FIELD(0)="ZRX"
- S FIELD(5)=PSOCANRC_"^"_$P($G(^VA(200,PSOCANRC,0)),"^")_"^"_"99NP"
- D SEG
- Q
- ;
- SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J))
- S COUNT=COUNT+1,MSG(COUNT)=SEGMENT
- Q
- SEND D MSG^XQOR("PS EVSEND OR",.MSG)
- Q
- ;
- SEGPAR ;Parse out fields for sending segments to OERR that can be >245
- K PSOFIELD
- S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)=""
- F MM=0:1:LIMIT S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|")
- I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1))
- F MM=0:1:LIMIT S SEG1=FIELD(MM) F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
- .S PVAR1=$E(SEG1,CC)
- .S PLIM=PVAR
- .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
- I $G(PVAR)'="" S PSOFIELD(CT)=PVAR
- S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG)) S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1
- K PSOFIELD
- Q
- ERROR ;Builds error message from PSOHLNEW, usually means we can't find order
- D EN^ORERR(COMM,.MSG)
- N MSG,PSOHINST
- S PSOMSORR=1 D INIT
- S MSG(2)=$G(PSERRPID)
- S MSG(3)=$G(PSERRPV1)
- S MSG(4)="ORC|"_$S($G(STAT)'="":$G(STAT),1:"DE")_"|"_PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"")
- F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER)
- I $G(COMM)'="" S $P(MSG(4),"|",17)="^^^^"_$G(COMM)
- D SEND K PSOMSORR Q
- ;
- RERROR ;
- F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
- N MSG
- S PSOMSORR=1 D INIT
- S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1)
- S MSG(4)="ORC|"_$S($G(XOFLAGZ):"UX",1:"UA")_"|"_$G(PLACER)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"")
- F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER)
- S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^"_$S($G(XOFLAGZ):"Patient mismatch on previous order.",$G(NWFLAG):"Patient Mismatch on new CPRS order",$G(PSOXRP):"Patient mismatch on Renewal.",1:"Duplicate Renewal Request. Order rejected by Pharmacy.")
- I $G(PSOCVI) S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^Order mismatch on Renewal."
- D SEND K PSOMSORR Q
- ;
- DCP ;
- K ^PS(52.41,"AOR",+$G(DFN),+$P($G(^PS(52.41,+$G(PREV),"INI")),"^"),+$G(PREV)) S $P(^PS(52.41,+$G(PREV),0),"^",3)="DE"
- S PSORPV=1 N PSOMSORR
- D EN^PSOHLSN(+$P($G(^PS(52.41,+$G(PREV),0)),"^"),"OC","","A")
- K PSORPV
- Q
- REN ;Update previous Rx on Cancel/Discontinue
- N RPREV,RENOC,RENOCP,RENSTA,PSOMSORR
- I $G(PSOHSTAT)'="OC",$G(PSOHSTAT)'="CR",$G(PSOHSTAT)'="DR",$G(PSOHSTAT)'="OD" Q
- Q:'$D(^PS(52.41,+$G(PSOPSIEN),0))
- S RPREV=$P($G(^PS(52.41,+$G(PSOPSIEN),0)),"^",21) Q:'$G(RPREV)!('$D(^PSRX(+$G(RPREV),0)))
- S RENSTA=$P($G(^PSRX(+$G(RPREV),"STA")),"^") Q:$G(RENSTA)=""
- S RENOC="SC",RENOCP=$S(RENSTA=0:"CM",(RENSTA=1!(RENSTA=4)):"IP",(RENSTA=3!(RENSTA=16)):"HD",RENSTA=5:"ZS",RENSTA=11:"ZE",RENSTA=15:"RP",1:"DC")
- D EN^PSOHLSN1(RPREV,RENOC,RENOCP,"","")
- Q
- ;
- DELP ;Delete refill requests
- I $G(PSODEATH) Q
- N DA,PENDDA
- S PENDDA=$P($G(^PSRX(+$G(PSRXIEN),"OR1")),"^",2) I 'PENDDA Q
- S DA=$O(^PS(52.41,"B",PENDDA,0)) I '$G(DA) Q
- I $P($G(^PS(52.41,DA,0)),"^",3)="RF" S DIK="^PS(52.41," D ^DIK K DIK
- Q
- SEGPARX ;
- N PSOFIELD
- S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)=""
- F MM=0:1:LIMIT I MM'=1 S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|")
- F MM=0:0 S MM=$O(FIELD(1,MM)) I '$O(FIELD(1,MM)) S FIELD(1,MM)=$S(FIELD(1,MM)="":"|",1:FIELD(1,MM)_"|") Q
- I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1))
- F MM=0:1:LIMIT S SEG1=FIELD(MM) D:MM=1 SEGXX I MM'=1 F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
- .S PVAR1=$E(SEG1,CC)
- .S PLIM=PVAR
- .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
- I $G(PVAR)'="" S PSOFIELD(CT)=PVAR
- S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG)) S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1
- Q
- SEGXX ;
- N MMZ F MMZ=0:0 S MMZ=$O(FIELD(MM,MMZ)) Q:'MMZ S SEG1=FIELD(MM,MMZ) F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
- .S PVAR1=$E(SEG1,CC)
- .S PLIM=PVAR
- .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
- Q
- CHKOLDRX ; when dc a pending renewal - if prior Rx is expired, set piece 19 to 1 so will update CPRS from 'renewed' to 'expired' in PSOHLSN1
- N PSOOLD
- S PSOOLD=$P($G(^PS(52.41,PSIEN,0)),"^",21)
- I PSOOLD'="",$P($G(^PSRX(PSOOLD,"STA")),"^")=11 S $P(^PSRX(PSOOLD,0),"^",19)=1
- Q
- PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94
- +1 ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121,292**;DEC 1997;Build 1
- +2 ;Externel reference EN^ORERR supported by DBIA 2187
- +3 ;
- +4 ; PS EVSEND OR PROTOCOL MUST BE OUR DRIVER RTN, (52 OR 52.41 INDICATOR
- +5 ; IS SENT THERE, THEN IT ROUTES, (NO NEED TO SEND FILE NUMBER HERE)
- EN(PLACER,STAT,COMM,PSNOO) ;
- +1 NEW DA,FIELD,J,JJ,MSG,LIMIT,NULLFLDS,PSIEN,PSOHINST,PSZERO,SEGMENT,NAME,DFN,COUNT,GG,CC,CT,MM,PVAR,PVAR1,PLIM,SEG1,SUBCOUNT,PSOPSTRT,PSOPSTOP,PSODFN,EDUZ,PSNOOTX,PSOHSTAT,PSOPSIEN
- +2 SET (PSIEN,PSOPSIEN)=$ORDER(^PS(52.41,"B",PLACER,0))
- +3 SET COUNT=0
- +4 ;I '$G(PSIEN) W !!,?5,"PROBLEM WITH ENTRY IN PENDING FILE!",! Q
- +5 IF '$GET(PSIEN)
- QUIT
- +6 IF $GET(STAT)="OC"!($GET(STAT)="OD")!($GET(STAT)="CR")!($GET(STAT)="DR")
- Begin DoDot:1
- +7 DO CHKOLDRX
- +8 IF $DATA(^PS(52.41,PSIEN,0))
- KILL ^PS(52.41,"AD",$PIECE(^PS(52.41,PSIEN,0),"^",12),+$PIECE($GET(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$PIECE(^PS(52.41,PSIEN,0),"^",13),+$PIECE(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$PIECE($GET(^PS(52.41,PSIEN,0)),"^",21),PSIEN)
- End DoDot:1
- +9 SET PSZERO=$GET(^PS(52.41,PSIEN,0))
- SET PSOHSTAT=$GET(STAT)
- +10 SET NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
- +11 DO INIT
- +12 IF $GET(STAT)="Z@"
- SET COUNT=1
- DO PID
- DO PV1
- DO ORC
- DO SEND
- QUIT
- +13 SET COUNT=1
- DO PID
- DO PV1
- DO ORC
- DO RXE
- DO ZRX
- DO SEND
- DO REN
- QUIT
- INIT KILL ^UTILITY("DIQ1",$JOB),DIQ
- SET DA=$PIECE($$SITE^VASITE(),"^")
- IF $GET(DA)
- SET DIC=4
- SET DIQ(0)="I"
- SET DR="99"
- DO EN^DIQ1
- SET PSOHINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
- KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIQ,DIC
- +1 SET MSG(1)="MSH|^~\&|PHARMACY|"_$GET(PSOHINST)_"|||||"_$SELECT($GET(PSOMSORR):"ORR",1:"ORM")
- +2 QUIT
- PID SET LIMIT=5
- XECUTE NULLFLDS
- +1 SET FIELD(0)="PID"
- +2 SET DFN=+$PIECE(PSZERO,"^",2)
- DO DEM^VADPT
- SET NAME=$GET(VADM(1))
- KILL VADM
- +3 SET FIELD(3)=DFN
- +4 SET FIELD(5)=NAME
- +5 DO SEG
- QUIT
- PV1 SET LIMIT=19
- XECUTE NULLFLDS
- +1 SET FIELD(0)="PV1"
- +2 SET FIELD(2)="O"
- +3 IF $PIECE($GET(^PS(52.41,PSIEN,0)),"^",13)
- SET FIELD(3)=$PIECE(^(0),"^",13)
- +4 DO SEG
- QUIT
- ORC SET LIMIT=15
- XECUTE NULLFLDS
- +1 SET FIELD(0)="ORC"
- +2 SET FIELD(1)=STAT
- +3 SET FIELD(2)=PLACER_$SELECT($GET(PLACERXX):";"_PLACERXX,1:"")_"^OR"
- +4 SET FIELD(3)=PSIEN_"S"_"^PS"
- +5 IF $GET(FIELD(5))=""
- IF $GET(STAT)="OR"!($GET(STAT)="OE")
- SET FIELD(5)="IP"
- +6 IF $GET(COMM)="IP"
- SET FIELD(5)="IP"
- +7 IF $GET(STAT)="SC"
- SET FIELD(5)=$SELECT($GET(COMM)="IP":"IP",$GET(COMM)="HD":"HD",$GET(COMM)="DC":"DC",1:"")
- +8 IF $GET(PSORPV)
- IF $GET(STAT)="OC"
- SET FIELD(5)="RP"
- +9 ;S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
- +10 ;I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
- +11 ;.S DT=$$DT^XLFDT
- +12 ;K X S FIELD(7)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
- +13 SET EDUZ=$PIECE($GET(^PS(52.41,PSIEN,0)),"^",4)
- IF EDUZ
- DO USER^PSOORFI2(EDUZ)
- SET FIELD(10)=EDUZ_"^"_USER1
- KILL USER1
- +14 IF $GET(PSOCANRC)
- IF $GET(PSOCANRN)'=""
- IF $GET(STAT)="OC"!($GET(STAT)="OD")
- SET FIELD(12)=$GET(PSOCANRC)_"^"_$GET(PSOCANRN)
- +15 IF '$GET(FIELD(12))
- DO USER^PSOORFI2($PIECE(^PS(52.41,PSIEN,0),"^",5))
- +16 IF '$GET(FIELD(12))
- SET FIELD(12)=$PIECE(^PS(52.41,PSIEN,0),"^",5)_"^"_USER1
- KILL USER1
- +17 SET FIELD(15)=$GET(PSOPSTRT)
- +18 DO SEG
- +19 IF $GET(COMM)'=""!($GET(PSNOO)'="")
- Begin DoDot:1
- +20 IF $GET(PSNOO)=""
- IF $GET(COMM)="IP"!($GET(COMM)="HD")!($GET(COMM)="DC")
- QUIT
- +21 IF $GET(PSNOO)'=""
- DO NOO^PSOHLSN1
- +22 IF '$DATA(COMM)
- SET COMM=""
- +23 IF $LENGTH($GET(COMM))+($LENGTH(MSG(COUNT)))+($LENGTH($GET(PSNOOTX)))+($SELECT($GET(PSNOO)'="":11,1:5))<245
- SET MSG(COUNT)=MSG(COUNT)_"|"_$GET(PSNOO)_"^"_$GET(PSNOOTX)_"^"_$SELECT($GET(PSNOO)'="":"99ORN",1:"")_"^^"_$SELECT(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$GET(COMM))_"^"
- QUIT
- +24 SET MSG(COUNT,1)="|"_$GET(PSNOO)_"^"_$GET(PSNOOTX)_"^"_$SELECT($GET(PSNOO)'="":"99ORN",1:"")_"^^"_$SELECT(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$GET(COMM))_"^"
- QUIT
- End DoDot:1
- +25 QUIT
- RXE SET LIMIT=1
- XECUTE NULLFLDS
- +1 SET FIELD(0)="RXE"
- +2 SET (PSOPSTRT,PSOPSTOP)=""
- SET X=$PIECE($GET(^PS(52.41,PSIEN,0)),"^",6)
- IF X
- SET PSOPSTRT=$$FMTHL7^XLFDT(X)
- +3 IF $GET(STAT)="CR"!($GET(STAT)="OC")
- IF '$GET(DT)
- Begin DoDot:1
- +4 SET DT=$$DT^XLFDT
- End DoDot:1
- SET X=DT
- SET PSOPSTOP=$$FMTHL7^XLFDT(X)
- +5 KILL X
- SET FIELD(1)="^^^"_$GET(PSOPSTRT)_"^"_$GET(PSOPSTOP)
- +6 DO SEG
- QUIT
- +7 ;
- ZRX ;
- +1 ;Only send if DC is from an external system
- +2 IF $GET(STAT)'="OC"
- IF $GET(STAT)'="OD"
- QUIT
- +3 IF '$GET(PSOHUIOR)!('$GET(PSOCANRC))
- QUIT
- +4 IF $PIECE($GET(^PS(52.41,PSIEN,"EXT")),"^")=""
- QUIT
- +5 SET LIMIT=5
- XECUTE NULLFLDS
- +6 SET FIELD(0)="ZRX"
- +7 SET FIELD(5)=PSOCANRC_"^"_$PIECE($GET(^VA(200,PSOCANRC,0)),"^")_"^"_"99NP"
- +8 DO SEG
- +9 QUIT
- +10 ;
- SEG SET SEGMENT=""
- FOR J=0:1:LIMIT
- SET SEGMENT=$SELECT(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J))
- +1 SET COUNT=COUNT+1
- SET MSG(COUNT)=SEGMENT
- +2 QUIT
- SEND DO MSG^XQOR("PS EVSEND OR",.MSG)
- +1 QUIT
- +2 ;
- SEGPAR ;Parse out fields for sending segments to OERR that can be >245
- +1 KILL PSOFIELD
- +2 SET COUNT=COUNT+1
- SET CT=1
- SET (PVAR,PVAR1)=""
- +3 FOR MM=0:1:LIMIT
- SET FIELD(MM)=$SELECT(FIELD(MM)="":"|",1:FIELD(MM)_"|")
- +4 IF $LENGTH(FIELD(LIMIT))>1
- SET FIELD(LIMIT)=$EXTRACT(FIELD(LIMIT),1,($LENGTH(FIELD(LIMIT))-1))
- +5 FOR MM=0:1:LIMIT
- SET SEG1=FIELD(MM)
- FOR CC=1:1:$LENGTH(SEG1)
- Begin DoDot:1
- +6 SET PVAR1=$EXTRACT(SEG1,CC)
- +7 SET PLIM=PVAR
- +8 SET PVAR=$SELECT(PVAR="":PVAR1,1:PVAR_PVAR1)
- End DoDot:1
- IF $LENGTH(PVAR)=245
- SET PSOFIELD(CT)=PVAR
- SET CT=CT+1
- SET PVAR=""
- +9 IF $GET(PVAR)'=""
- SET PSOFIELD(CT)=PVAR
- +10 SET MSG(COUNT)=PSOFIELD(1)
- SET SUBCOUNT=1
- FOR GG=2:1
- IF '$DATA(PSOFIELD(GG))
- QUIT
- SET MSG(COUNT,SUBCOUNT)=PSOFIELD(GG)
- SET SUBCOUNT=SUBCOUNT+1
- +11 KILL PSOFIELD
- +12 QUIT
- ERROR ;Builds error message from PSOHLNEW, usually means we can't find order
- +1 DO EN^ORERR(COMM,.MSG)
- +2 NEW MSG,PSOHINST
- +3 SET PSOMSORR=1
- DO INIT
- +4 SET MSG(2)=$GET(PSERRPID)
- +5 SET MSG(3)=$GET(PSERRPV1)
- +6 SET MSG(4)="ORC|"_$SELECT($GET(STAT)'="":$GET(STAT),1:"DE")_"|"_PLACER_$SELECT($GET(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$SELECT($PIECE($GET(PSERRORC),"|",4)'="":$PIECE(PSERRORC,"|",4),1:"")
- +7 FOR EER=11,13
- IF $PIECE($GET(PSERRORC),"|",EER)'=""
- SET $PIECE(MSG(4),"|",EER)=$PIECE($GET(PSERRORC),"|",EER)
- +8 IF $GET(COMM)'=""
- SET $PIECE(MSG(4),"|",17)="^^^^"_$GET(COMM)
- +9 DO SEND
- KILL PSOMSORR
- QUIT
- +10 ;
- RERROR ;
- +1 FOR EER=0:0
- SET EER=$ORDER(MSG(EER))
- IF 'EER
- QUIT
- IF $PIECE(MSG(EER),"|")="PV1"
- SET PSERRPV1=MSG(EER)
- IF $PIECE(MSG(EER),"|")="PID"
- SET PSERRPID=MSG(EER)
- IF $PIECE(MSG(EER),"|")="ORC"&($GET(PSERRORC)="")
- SET PSERRORC=MSG(EER)
- +2 NEW MSG
- +3 SET PSOMSORR=1
- DO INIT
- +4 SET MSG(2)=$GET(PSERRPID)
- SET MSG(3)=$GET(PSERRPV1)
- +5 SET MSG(4)="ORC|"_$SELECT($GET(XOFLAGZ):"UX",1:"UA")_"|"_$GET(PLACER)_$SELECT($GET(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$SELECT($PIECE($GET(PSERRORC),"|",4)'="":$PIECE(PSERRORC,"|",4),1:"")
- +6 FOR EER=11,13
- IF $PIECE($GET(PSERRORC),"|",EER)'=""
- SET $PIECE(MSG(4),"|",EER)=$PIECE($GET(PSERRORC),"|",EER)
- +7 SET $PIECE(MSG(4),"|",17)="D^Duplicate^99ORN^^"_...
- ... $SELECT($GET(XOFLAGZ):"Patient mismatch on previous order.",$GET(NWFLAG):"Patient Mismatch on new CPRS order",$GET(PSOXRP):"Patient mismatch on Renewal.",1:"Duplicate Renewal Request. Order rejected by Pharmacy.")
- +8 IF $GET(PSOCVI)
- SET $PIECE(MSG(4),"|",17)="D^Duplicate^99ORN^^Order mismatch on Renewal."
- +9 DO SEND
- KILL PSOMSORR
- QUIT
- +10 ;
- DCP ;
- +1 KILL ^PS(52.41,"AOR",+$GET(DFN),+$PIECE($GET(^PS(52.41,+$GET(PREV),"INI")),"^"),+$GET(PREV))
- SET $PIECE(^PS(52.41,+$GET(PREV),0),"^",3)="DE"
- +2 SET PSORPV=1
- NEW PSOMSORR
- +3 DO EN^PSOHLSN(+$PIECE($GET(^PS(52.41,+$GET(PREV),0)),"^"),"OC","","A")
- +4 KILL PSORPV
- +5 QUIT
- REN ;Update previous Rx on Cancel/Discontinue
- +1 NEW RPREV,RENOC,RENOCP,RENSTA,PSOMSORR
- +2 IF $GET(PSOHSTAT)'="OC"
- IF $GET(PSOHSTAT)'="CR"
- IF $GET(PSOHSTAT)'="DR"
- IF $GET(PSOHSTAT)'="OD"
- QUIT
- +3 IF '$DATA(^PS(52.41,+$GET(PSOPSIEN),0))
- QUIT
- +4 SET RPREV=$PIECE($GET(^PS(52.41,+$GET(PSOPSIEN),0)),"^",21)
- IF '$GET(RPREV)!('$DATA(^PSRX(+$GET(RPREV),0)))
- QUIT
- +5 SET RENSTA=$PIECE($GET(^PSRX(+$GET(RPREV),"STA")),"^")
- IF $GET(RENSTA)=""
- QUIT
- +6 SET RENOC="SC"
- SET RENOCP=$SELECT(RENSTA=0:"CM",(RENSTA=1!(RENSTA=4)):"IP",(RENSTA=3!(RENSTA=16)):"HD",RENSTA=5:"ZS",RENSTA=11:"ZE",RENSTA=15:"RP",1:"DC")
- +7 DO EN^PSOHLSN1(RPREV,RENOC,RENOCP,"","")
- +8 QUIT
- +9 ;
- DELP ;Delete refill requests
- +1 IF $GET(PSODEATH)
- QUIT
- +2 NEW DA,PENDDA
- +3 SET PENDDA=$PIECE($GET(^PSRX(+$GET(PSRXIEN),"OR1")),"^",2)
- IF 'PENDDA
- QUIT
- +4 SET DA=$ORDER(^PS(52.41,"B",PENDDA,0))
- IF '$GET(DA)
- QUIT
- +5 IF $PIECE($GET(^PS(52.41,DA,0)),"^",3)="RF"
- SET DIK="^PS(52.41,"
- DO ^DIK
- KILL DIK
- +6 QUIT
- SEGPARX ;
- +1 NEW PSOFIELD
- +2 SET COUNT=COUNT+1
- SET CT=1
- SET (PVAR,PVAR1)=""
- +3 FOR MM=0:1:LIMIT
- IF MM'=1
- SET FIELD(MM)=$SELECT(FIELD(MM)="":"|",1:FIELD(MM)_"|")
- +4 FOR MM=0:0
- SET MM=$ORDER(FIELD(1,MM))
- IF '$ORDER(FIELD(1,MM))
- SET FIELD(1,MM)=$SELECT(FIELD(1,MM)="":"|",1:FIELD(1,MM)_"|")
- QUIT
- +5 IF $LENGTH(FIELD(LIMIT))>1
- SET FIELD(LIMIT)=$EXTRACT(FIELD(LIMIT),1,($LENGTH(FIELD(LIMIT))-1))
- +6 FOR MM=0:1:LIMIT
- SET SEG1=FIELD(MM)
- IF MM=1
- DO SEGXX
- IF MM'=1
- FOR CC=1:1:$LENGTH(SEG1)
- Begin DoDot:1
- +7 SET PVAR1=$EXTRACT(SEG1,CC)
- +8 SET PLIM=PVAR
- +9 SET PVAR=$SELECT(PVAR="":PVAR1,1:PVAR_PVAR1)
- End DoDot:1
- IF $LENGTH(PVAR)=245
- SET PSOFIELD(CT)=PVAR
- SET CT=CT+1
- SET PVAR=""
- +10 IF $GET(PVAR)'=""
- SET PSOFIELD(CT)=PVAR
- +11 SET MSG(COUNT)=PSOFIELD(1)
- SET SUBCOUNT=1
- FOR GG=2:1
- IF '$DATA(PSOFIELD(GG))
- QUIT
- SET MSG(COUNT,SUBCOUNT)=PSOFIELD(GG)
- SET SUBCOUNT=SUBCOUNT+1
- +12 QUIT
- SEGXX ;
- +1 NEW MMZ
- FOR MMZ=0:0
- SET MMZ=$ORDER(FIELD(MM,MMZ))
- IF 'MMZ
- QUIT
- SET SEG1=FIELD(MM,MMZ)
- FOR CC=1:1:$LENGTH(SEG1)
- Begin DoDot:1
- +2 SET PVAR1=$EXTRACT(SEG1,CC)
- +3 SET PLIM=PVAR
- +4 SET PVAR=$SELECT(PVAR="":PVAR1,1:PVAR_PVAR1)
- End DoDot:1
- IF $LENGTH(PVAR)=245
- SET PSOFIELD(CT)=PVAR
- SET CT=CT+1
- SET PVAR=""
- +5 QUIT
- CHKOLDRX ; when dc a pending renewal - if prior Rx is expired, set piece 19 to 1 so will update CPRS from 'renewed' to 'expired' in PSOHLSN1
- +1 NEW PSOOLD
- +2 SET PSOOLD=$PIECE($GET(^PS(52.41,PSIEN,0)),"^",21)
- +3 IF PSOOLD'=""
- IF $PIECE($GET(^PSRX(PSOOLD,"STA")),"^")=11
- SET $PIECE(^PSRX(PSOOLD,0),"^",19)=1
- +4 QUIT