- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE2.m
r613 r623 1 PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ;1/20/952 ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46,225**;DEC 1997;Build 29 3 4 5 6 7 8 9 10 EN 11 12 13 14 15 16 17 18 19 20 PARSE 21 22 23 24 25 26 27 SET 28 29 OBXX 30 31 32 33 34 35 36 37 38 39 40 41 OPARSE 42 43 44 OSET 45 46 PURGE 47 48 49 50 51 52 53 54 55 56 57 58 59 PDERR 60 61 PDNO 62 63 64 65 66 PURGEX 67 PRX 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 PUQUIT 84 85 REF 86 87 88 89 90 91 92 93 94 95 96 REFERR 97 98 REFSND 99 100 101 102 103 104 105 REFSNDX 106 107 REFRX 108 109 110 111 112 113 114 115 116 117 118 119 120 121 PIDZ 122 123 124 PV1Z 125 126 127 128 129 130 131 132 133 ORCZ 134 135 136 ZRXZ 137 138 139 STUFF 140 141 142 143 144 F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$$UNESC^ORHLESC($G(PSOVRB))145 146 1 PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ; 1/20/95 2 ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46**;DEC 1997 3 ;External reference to DG(40.8 supported by DBIA 728 4 ;External reference to PS(50.606 supported by DBIA 2174 5 ;External reference to PS(50.7 supported by DBIA 2223 6 ;External reference to PSDRUG( supported by DBIA 221 7 ;External reference to PS(55 supported by DBIA 2228 8 ;External reference to SC( supported by DBIA 2675 9 ; 10 EN ;RXO segment on new orders with multiple subscripts 11 S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) 12 S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="|" PARSE 13 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 14 .S POVAR1=$E(MSG(ZZ,AAA),OOO) 15 .S POLIM=POVAR 16 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) 17 I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR 18 K MSG(ZZ,0) 19 Q 20 PARSE ; 21 I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET 22 I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET 23 I NNNN=10 G SET 24 I NNNN=11 S PSOXQTY=POLIM G SET 25 I NNNN=13 S PSOREFIL=POLIM G SET 26 I NNNN=17 S PSODYSPL=POLIM 27 SET S (POVAR,POLIM)="" Q 28 ; 29 OBXX ;Parse out OBX segments 30 S OCOUNT=OCOUNT+1 31 S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) 32 S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE 33 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 34 .S POVAR1=$E(MSG(ZZ,AAA),OOO) 35 .S POLIM=POVAR 36 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) 37 I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR 38 K MSG(ZZ,0) 39 F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO)) S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO) 40 Q 41 OPARSE ; 42 I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET 43 I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM) 44 OSET S (POVAR,POLIM)="" Q 45 ; 46 PURGE ;Purge order initiated by CPRS 47 N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE 48 S PSOMSORR=1 49 S PRGFLAG=0 50 ;S PURGRX=$O(^PSRX("APL",OR("PLACE"),0)) I PURGRX G PRX 51 I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX 52 S PND=+$G(PSOFILNM) I PND D G PDNO 53 .I '$D(^PS(52.41,PND,0)) Q 54 .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q 55 .S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q 56 .K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q 57 S PURGCOMM="Order was not located by Pharmacy." 58 D PDERR G PDNO 59 PDERR D EN^ORERR(PURGCOMM,.MSG) 60 Q 61 PDNO F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER) 62 N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"") 63 F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER) 64 S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^" 65 D SEND^PSOHLSN 66 PURGEX K PSOMSORR Q 67 PRX ;Purge from PSRX here 68 I '$D(^PSRX(PURGRX,0)) G PDNO 69 I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO 70 I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO 71 ;purge from PSRX 72 S PURGEXRX=$P(^PSRX(PURGRX,0),"^") 73 S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA 74 I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK 75 I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK 76 S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA 77 I '$G(DT) S DT=$$DT^XLFDT 78 I '$G(PSCC) G PUQUIT 79 I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT 80 S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC S PLAST=PSARC 81 I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT 82 S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE 83 PUQUIT G PDNO 84 ; 85 REF ;Refill request from CPRS 86 N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR 87 ;S PSOMSORR=1 88 ;S PSORXFL=$O(^PSRX("APL",OR("PLACE"),0)) I PSORXFL G REFRX 89 I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX 90 I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D S REFXXX=1 G REFSND 91 .I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q 92 .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q 93 .I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q 94 .S REFCOM="Refill request not allowed on Pending order." 95 S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND 96 REFERR D EN^ORERR(REFCOMXX,.MSG) 97 Q 98 REFSND ;REBUILD AND SEND MESSAGE REFXXX IS VARIABL, REFCOM IS COMMENT 99 ;F REFEER=0:0 S REFEER=$O(MSG(REFEER)) Q:'REFEER S:$P(MSG(REFEER),"|")="PV1" REFPV1=MSG(REFEER) S:$P(MSG(REFEER),"|")="PID" REFPID=MSG(REFEER) S:$P(MSG(REFEER),"|")="ORC"&($G(REFORC)="") REFORC=MSG(REFEER) 100 ;N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(REFPID),MSG(3)=$G(REFPV1),MSG(4)="ORC|"_$S($G(REFXXX):"UF",1:"FL")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(REFORC),"|",4)'="":$P(REFORC,"|",4),1:"") 101 ;use commented out code if response message is ever required 102 ;F RREER=11,13 I $P($G(REFORC),"|",RREER)'="" S $P(MSG(4),"|",RREER)=$P($G(REFORC),"|",RREER) 103 ;S $P(MSG(4),"|",17)="^^^^"_$S($G(REFXXX):$G(REFCOM),1:"Refill request sent to Pharmacy.")_"^" 104 ;D SEND^PSOHLSN 105 REFSNDX ;K PSOMSORR 106 Q 107 REFRX ; 108 I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND 109 I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND 110 I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND 111 ;S REFVR=$$REFILL^PSOREF(OR("PLACE")) I $P($G(REFVR),"^")'=1 S REFXXX=1,REFCOM=$P($G(REFVR),"^",2) G REFSND 112 F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE 113 I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND 114 I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND 115 K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND 116 S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R" 117 S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6) 118 S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K % 119 K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK 120 G REFSND 121 PIDZ ; 122 S DFN=+$P(REFSEG,"|",3) 123 Q 124 PV1Z ; 125 S LOCATION=+$P(+$P(REFSEG,"|",3),"^") 126 S:'$D(^SC(LOCATION,0)) LOCATION="" 127 S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q 128 I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15) 129 I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0)) 130 I '$G(DT) S DT=$$DT^XLFDT 131 S PSINPTR=+$$SITE^VASITE(DT,INPTRX) 132 Q 133 ORCZ ; 134 S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12) 135 Q 136 ZRXZ ; 137 S ROUTING=$P(REFSEG,"|",4) 138 Q 139 STUFF ; 140 S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2) 141 I '$G(PSOVRBD) K PSOVRBD Q 142 ;K PSONUNN F PSONUN=0:0 S PSONUN=$O(^PS(50.606,PSOVRBD,"NOUN",PSONUN)) Q:'PSONUN!($D(PSONUNN)) S:$P($G(^(PSONUN,0)),"^")'="" PSONUNN=$P($G(^(0)),"^") 143 S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^") 144 F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$G(PSOVRB) 145 K PSOVRBD,PSONUNN,PSONUN,PSOVRB 146 Q
Note:
See TracChangeset
for help on using the changeset viewer.
