- PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;October 20, 2022@13:54
- ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239,292,225,296,323,441,545**;DEC 1997;Build 270
- ;Ref #50.606-DBIA 2174
- ;#50.607-2221
- ;#50.7-2223
- ;#51.2-2226
- ;#50-221
- ;PSNDF-2195
- ;EN^PSSUTIL1-3179
- ;
- EN(PSRXIEN,STAT,PSSTAT,COMM,PSNOO) ;
- N COUNT,DFN,J,LIMIT,NAME,NULLFLDS,PSDIEN,PSFLAG,PSND1,PSND2,PSND3,PRODUCT,UNIT,POIPTR,PSOHINST,PODOSE,PODOSENM,PSROUTE,RTNAME,SEGMENT,CCC,BBB,CSCOUNT,PPTR,MSG,PSOHSTRT,PSOHSTOP,PSOHISSD,PSORTLP,ZRXFLAG,RXE2FLAG,RXE2ONLY,PSODFN,EDUZ
- N PSOCDDUZ,DA,FSIG,BSIG,PSHRX,PSHORX,PSNOOTX,ZPRE,PSOZSTAT,CCCX,PSOCPS,PSOICD
- K FIELD
- I $G(STAT)="" Q
- I STAT="CR"!(STAT="DR")!(STAT="HR")!(STAT="OC")!(STAT="OD")!(STAT="OH")!(STAT="Z@")!(STAT="RP") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT G SKIP
- I STAT="SC" I $G(PSSTAT)="ZE"!($G(PSSTAT)="HD")!($G(PSSTAT)="DC") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT
- SKIP ;
- I $G(STAT)="SC",$G(PSSTAT)="ZE",$P($G(^PSRX(+$G(PSRXIEN),0)),"^",19)=2 Q
- I $G(STAT)="RP" S STAT="OD",PSSTAT="RP"
- S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
- I '$D(^PSRX(PSRXIEN,0)) Q
- I ($G(STAT)="SC"&($G(PSSTAT)="ZE"))!($G(STAT)="OC")!($G(STAT)="OD") I $D(^PS(52.41,"AQ",PSRXIEN)) D EN^PSOHDR("PRES",PSRXIEN) Q
- I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q
- I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2
- D INIT
- S COUNT=1,(ZRXFLAG,RXE2FLAG,RXE2ONLY)=0 D PID,PV1,ORC
- I $G(STAT)="Z@" G NCM
- I $G(STAT)="OK"!($G(STAT)="SN")!($G(STAT)="ZC")!($G(STAT)="XX")!($G(STAT)="SC")!($G(STAT)="RO") D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL G NCM
- I $G(STAT)="SC",$G(PSSTAT)="CM" D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL
- I '$G(RXE2FLAG) S RXE2ONLY=1 D RXE,SEGPARX^PSOHLSN
- I '$G(ZRXFLAG) D ZRX
- NCM D SEND
- K PSRXIEN 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 DFN=+$P(^PSRX(PSRXIEN,0),"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM
- S FIELD(0)="PID"
- S FIELD(3)=DFN
- S FIELD(5)=NAME
- D SEG Q
- DG1 D DG1^PSOHLSN2
- Q
- PV1 ;
- S LIMIT=19 X NULLFLDS
- S FIELD(0)="PV1"
- S FIELD(2)="O"
- S:$P(^PSRX(PSRXIEN,0),"^",5) FIELD(3)=$P(^(0),"^",5)
- D SEG Q
- ORC ;
- D ORC^PSOHLSN3
- Q
- ;
- RXO ;
- S LIMIT=1 X NULLFLDS
- S FIELD(0)="RXO"
- S PPTR=+$P($G(^PSRX(PSRXIEN,"OR1")),"^")
- S FIELD(1)=$S('PPTR:"^^^^^",1:"^^^"_PPTR_"^"_$P($G(^PS(50.7,PPTR,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP")
- S $P(FIELD(1),"|",20)=$P($G(^PSRX(PSRXIEN,"IND")),"^") ;*441-IND
- D SEG Q
- ;
- RXE ;
- S RXE2FLAG=1
- S LIMIT=$S('$G(RXE2ONLY):26,1:2) X NULLFLDS
- S FIELD(0)="RXE"
- S (PSOHSTRT,PSOHSTOP)="" S X=$P($G(^PSRX(PSRXIEN,2)),"^",2) I X S PSOHSTRT=$$FMTHL7^XLFDT(X)
- I '$G(DT) S DT=$$DT^XLFDT
- S X=$S($P($G(^PSRX(PSRXIEN,3)),"^",5):$P($G(^(3)),"^",5),$G(STAT)="OD"!($G(STAT)="OC"):$G(DT),$P($G(^(2)),"^",6):$P($G(^(2)),"^",6),1:$G(DT)) I X S PSOHSTOP=$$FMTHL7^XLFDT(X)
- K X N PSOMZT,MMZZ,MMZZT S MMZZT=1 F MMZZ=0:0 S MMZZ=$O(^PSRX(PSRXIEN,6,MMZZ)) Q:'MMZZ D:$D(^(MMZZ,0))
- .S FIELD(1,MMZZT)=$S($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2):$$ESC^ORHLESC($P($G(^(0)),"^"))_"\T\"_$P($G(^PS(50.607,+$P($G(^(0)),"^",3),0)),"^")_"\T\"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2)_"\T\"_$P($G(^(0)),"^",4),1:"")
- .S FIELD(1,MMZZT)=FIELD(1,MMZZT)_"^"_$$ESC^ORHLESC($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",8))
- .I $P($G(FIELD(1,MMZZT)),"^")'="" F PSOMZT=1,3 I $E($P(FIELD(1,MMZZT),"\T\",PSOMZT),1)="." S $P(FIELD(1,MMZZT),"\T\",PSOMZT)="0"_$P(FIELD(1,MMZZT),"\T\",PSOMZT)
- .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$$DUR(PSRXIEN,MMZZ)_"^^^^^"_$S($P($G(FIELD(1,MMZZT)),"^")'="":$P($G(FIELD(1,MMZZT)),"\T\")_$P($G(FIELD(1,MMZZT)),"\T\",2),1:$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^"))
- .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",6)
- .I $O(^PSRX(PSRXIEN,6,MMZZ)) S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"~"
- .S MMZZT=MMZZT+1
- S $P(FIELD(1,1),"^",4)=$G(PSOHSTRT),$P(FIELD(1,$S(MMZZT>1:MMZZT-1,1:1)),"^",5)=$G(PSOHSTOP)
- S PSFLAG=0,PSDIEN=+$P(^PSRX(PSRXIEN,0),"^",6),PSND1=$P($G(^PSDRUG(PSDIEN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3) I PSND1,PSND3 S PSFLAG=1
- S FIELD(2)=$S(PSFLAG:PSND1_"."_PSND3_"^"_$$ESC^ORHLESC(PSND2)_"^"_"99NDF",1:"^^")_"^"_PSDIEN_"^"_$$ESC^ORHLESC($P($G(^PSDRUG(PSDIEN,0)),"^"))_"^"_"99PSD"
- Q:$G(RXE2ONLY)
- I PSFLAG D
- .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3) S FIELD(5)="^^^"_$P($G(PSOXN),"^",5)_"^"_$$ESC^ORHLESC($P($G(PSOXN),"^",6))_"^"_"99PSU" K PSOXN Q
- .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0)) S UNIT=$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^")
- .S FIELD(5)="^^^"_UNIT_"^"_$$ESC^ORHLESC($P($G(^PS(50.607,+UNIT,0)),"^"))_"^"_"99PSU"
- S POIPTR=$P($G(^PSRX(PSRXIEN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$P($G(^PS(50.606,+PODOSE,0)),"^")
- I POIPTR S FIELD(6)="^^^"_$G(PODOSE)_"^"_$$ESC^ORHLESC($G(PODOSENM))_"^"_"99PSF"
- S FIELD(10)=$P(^PSRX(PSRXIEN,0),"^",7)
- S FIELD(12)=$P(^PSRX(PSRXIEN,0),"^",9)
- ;*545 - set RXE with the selected DEA#
- I $G(PSRXIEN),$D(^TMP("PSORXN",$J,PSRXIEN,"DEA")) S FIELD(13)=^TMP("PSORXN",$J,PSRXIEN,"DEA")
- S FIELD(14)=$P(^PSRX(PSRXIEN,0),"^",4)
- S FIELD(15)=$P(^PSRX(PSRXIEN,0),"^")
- S FIELD(22)=$P(^PSRX(PSRXIEN,0),"^",8)
- K MMZZ S MMZZ=$$EN^PSSUTIL1(PSDIEN) S FIELD(25)=$S($E($P(MMZZ,"|"),1)=".":"0",1:"")_$P(MMZZ,"|"),FIELD(26)=$P(MMZZ,"|",2)
- N PLIM,PVAR,PVAR1,SUBCOUNT D SEGPARX^PSOHLSN
- ;
- I $O(^PSRX(PSRXIEN,"PRC",0)) D
- .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"PRC",0))
- .S MSG(COUNT)="NTE|6||"_$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"PRC",CCC,0)))
- .S CSCOUNT=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"PRC",CCC)) Q:'CCC S MSG(COUNT,CSCOUNT)=$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"PRC",CCC,0))),CSCOUNT=CSCOUNT+1
- I $O(^PSRX(PSRXIEN,"INS1",0)) D
- .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"INS1",0))
- .S MSG(COUNT)="NTE|7|L|"_$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"INS1",CCC,0)))
- .S CCCX=1 F S CCC=$O(^PSRX(PSRXIEN,"INS1",CCC)) Q:'CCC I $D(^PSRX(PSRXIEN,"INS1",CCC,0)) S MSG(COUNT,CCCX)=$$ESC^ORHLESC($G(^(0))) S CCCX=CCCX+1
- S COUNT=COUNT+1
- I $P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D Q
- .D FSIG^PSOUTLA("R",PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(FSIG(1))'="":$$ESC^ORHLESC($G(FSIG(1))),1:"No SIG available") I $O(FSIG(1)) F CCC=1:0 S CCC=$O(FSIG(CCC)) Q:'CCC S MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($G(FSIG(CCC)))
- I '$P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D Q
- .D EN3^PSOUTLA1(PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(BSIG(1))'="":$$ESC^ORHLESC($G(BSIG(1))),1:"No SIG available") I $O(BSIG(1)) F CCC=1:0 S CCC=$O(BSIG(CCC)) Q:'CCC S MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($G(BSIG(CCC)))
- Q
- ;
- RXR ;
- F PSORTLP=0:0 S PSORTLP=$O(^PSRX(PSRXIEN,6,PSORTLP)) Q:'PSORTLP D
- .S LIMIT=1 X NULLFLDS
- .S FIELD(0)="RXR"
- .S PSROUTE=$P($G(^PSRX(PSRXIEN,6,PSORTLP,0)),"^",7) I PSROUTE,$D(^PS(51.2,PSROUTE,0)) S RTNAME=$P(^PS(51.2,PSROUTE,0),"^")
- .S FIELD(1)="^^^"_$G(PSROUTE)_"^"_$G(RTNAME)_"^"_"99PSR"
- .D SEG
- Q
- ;
- ZCL D ZCL^PSOHLSN2
- Q
- ZSC D ZSC^PSOHLSN2
- Q
- ;
- ZRX ;
- S ZRXFLAG=1
- S LIMIT=8 X NULLFLDS
- S FIELD(0)="ZRX"
- S ZPRE=$P($G(^PSRX(PSRXIEN,"OR1")),"^",3) I ZPRE S FIELD(1)=$P($G(^PSRX(ZPRE,"OR1")),"^",2)
- I '$G(FIELD(1)),$G(PSORDEDT) S FIELD(1)=$P($G(^PS(52.41,$G(PSORDEDT),0)),"^")
- S FIELD(2)=$G(PSNOO)
- I $G(STAT)="SN"!($G(STAT)="RO") S FIELD(3)=$S($G(STAT)="RO"!($G(PSOEDIT)):"E",$G(PSOOPT)=3:"R",1:"N")
- S FIELD(4)=$P(^PSRX(PSRXIEN,0),"^",11)
- S PSOCDDUZ=$S($G(PSOROPCH)="PATCH":$P($G(^PSRX(PSRXIEN,"OR1")),"^",5),$G(PSOHUIOR)&($P($G(^PSRX(PSRXIEN,"EXT")),"^")'=""):+$G(PSOCANRC),1:$G(DUZ))
- I $G(PSOCDDUZ) S FIELD(5)=PSOCDDUZ_"^"_$P($G(^VA(200,PSOCDDUZ,0)),"^")_"^"_"99NP"
- I $G(STAT)="ZD",$G(PSODISPP) S FIELD(6)="P"
- S FIELD(8)=$P($G(^PSRX(PSRXIEN,"TIT")),"^",3)
- 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:$G(PSRXIEN)&($T(EN^PSOHDR)]"")&($G(PSOSSMES)'="CPRSUP") K FIELD D MSG^XQOR("PS EVSEND OR",.MSG) Q
- .I $G(STAT)="ZC"!($G(STAT)="UC")!($G(STAT)="UD")!($G(STAT)="UH")!($G(STAT)="UR")!($G(STAT)="DE")!($G(STAT)="ZD")!($G(STAT)="SN")!($G(STAT)="Z@") Q
- .I $G(STAT)="SC",$G(PSSTAT)="ZZ" Q
- .D EN^PSOHDR("PRES",PSRXIEN)
- ;
- NOO ;
- I $G(PSNOO)="" S PSNOOTX="" Q
- S PSNOOTX=$S(PSNOO="W":"Written",PSNOO="V":"Verbal",PSNOO="P":"Telephoned",PSNOO="S":"Service Correction",PSNOO="X":"Rejected",PSNOO="D":"Duplicate",PSNOO="I":"Policy",PSNOO="E":"Physician Entered",PSNOO="A":"Auto DC",1:"") Q
- Q
- ;
- DUR(PSODX1,PSODX2) ;
- N PSODX,PSODX4,PSODX5,PSODX6,PSODX7 S PSODX=$P($G(^PSRX(PSODX1,6,PSODX2,0)),"^",5)
- I 'PSODX Q PSODX
- S PSODX4=$L(PSODX),PSODX5=$E(PSODX,PSODX4)
- S PSODX=$S(PSODX5?1A:PSODX,1:PSODX_"D")
- S PSODX6=$L(PSODX)
- S PSODX7=$E(PSODX,PSODX6)_$E(PSODX,1,(PSODX6-1))
- Q PSODX7
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLSN1 9019 printed Jan 18, 2025@03:31:20 Page 2
- PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;October 20, 2022@13:54
- +1 ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239,292,225,296,323,441,545**;DEC 1997;Build 270
- +2 ;Ref #50.606-DBIA 2174
- +3 ;#50.607-2221
- +4 ;#50.7-2223
- +5 ;#51.2-2226
- +6 ;#50-221
- +7 ;PSNDF-2195
- +8 ;EN^PSSUTIL1-3179
- +9 ;
- EN(PSRXIEN,STAT,PSSTAT,COMM,PSNOO) ;
- +1 NEW COUNT,DFN,J,LIMIT,NAME,NULLFLDS,PSDIEN,PSFLAG,PSND1,PSND2,PSND3,PRODUCT,UNIT,POIPTR,PSOHINST,PODOSE,PODOSENM,PSROUTE,RTNAME,SEGMENT,CCC,BBB,CSCOUNT,PPTR,MSG,PSOHSTRT,PSOHSTOP,PSOHISSD,PSORTLP,ZRXFLAG,RXE2FLAG,RXE2ONLY,PSODFN,EDUZ
- +2 NEW PSOCDDUZ,DA,FSIG,BSIG,PSHRX,PSHORX,PSNOOTX,ZPRE,PSOZSTAT,CCCX,PSOCPS,PSOICD
- +3 KILL FIELD
- +4 IF $GET(STAT)=""
- QUIT
- +5 IF STAT="CR"!(STAT="DR")!(STAT="HR")!(STAT="OC")!(STAT="OD")!(STAT="OH")!(STAT="Z@")!(STAT="RP")
- SET PSOZSTAT=STAT
- DO DELP^PSOHLSN
- SET STAT=PSOZSTAT
- GOTO SKIP
- +6 IF STAT="SC"
- IF $GET(PSSTAT)="ZE"!($GET(PSSTAT)="HD")!($GET(PSSTAT)="DC")
- SET PSOZSTAT=STAT
- DO DELP^PSOHLSN
- SET STAT=PSOZSTAT
- SKIP ;
- +1 IF $GET(STAT)="SC"
- IF $GET(PSSTAT)="ZE"
- IF $PIECE($GET(^PSRX(+$GET(PSRXIEN),0)),"^",19)=2
- QUIT
- +2 IF $GET(STAT)="RP"
- SET STAT="OD"
- SET PSSTAT="RP"
- +3 SET COUNT=0
- SET NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
- +4 IF '$DATA(^PSRX(PSRXIEN,0))
- QUIT
- +5 IF ($GET(STAT)="SC"&($GET(PSSTAT)="ZE"))!($GET(STAT)="OC")!($GET(STAT)="OD")
- IF $DATA(^PS(52.41,"AQ",PSRXIEN))
- DO EN^PSOHDR("PRES",PSRXIEN)
- QUIT
- +6 IF STAT'="SN"
- IF STAT'="ZC"
- IF '$PIECE($GET(^PSRX(PSRXIEN,"OR1")),"^",2)
- QUIT
- +7 IF $GET(STAT)="SC"
- IF $GET(PSSTAT)="ZE"
- SET $PIECE(^PSRX(PSRXIEN,0),"^",19)=2
- +8 DO INIT
- +9 SET COUNT=1
- SET (ZRXFLAG,RXE2FLAG,RXE2ONLY)=0
- DO PID
- DO PV1
- DO ORC
- +10 IF $GET(STAT)="Z@"
- GOTO NCM
- +11 IF $GET(STAT)="OK"!($GET(STAT)="SN")!($GET(STAT)="ZC")!($GET(STAT)="XX")!($GET(STAT)="SC")!($GET(STAT)="RO")
- DO RXO
- DO RXE
- DO RXR
- DO ZRX
- DO DG1
- DO ZSC
- DO ZCL
- GOTO NCM
- +12 IF $GET(STAT)="SC"
- IF $GET(PSSTAT)="CM"
- DO RXO
- DO RXE
- DO RXR
- DO ZRX
- DO DG1
- DO ZSC
- DO ZCL
- +13 IF '$GET(RXE2FLAG)
- SET RXE2ONLY=1
- DO RXE
- DO SEGPARX^PSOHLSN
- +14 IF '$GET(ZRXFLAG)
- DO ZRX
- NCM DO SEND
- +1 KILL PSRXIEN
- 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 DFN=+$PIECE(^PSRX(PSRXIEN,0),"^",2)
- DO DEM^VADPT
- SET NAME=$GET(VADM(1))
- KILL VADM
- +2 SET FIELD(0)="PID"
- +3 SET FIELD(3)=DFN
- +4 SET FIELD(5)=NAME
- +5 DO SEG
- QUIT
- DG1 DO DG1^PSOHLSN2
- +1 QUIT
- PV1 ;
- +1 SET LIMIT=19
- XECUTE NULLFLDS
- +2 SET FIELD(0)="PV1"
- +3 SET FIELD(2)="O"
- +4 if $PIECE(^PSRX(PSRXIEN,0),"^",5)
- SET FIELD(3)=$PIECE(^(0),"^",5)
- +5 DO SEG
- QUIT
- ORC ;
- +1 DO ORC^PSOHLSN3
- +2 QUIT
- +3 ;
- RXO ;
- +1 SET LIMIT=1
- XECUTE NULLFLDS
- +2 SET FIELD(0)="RXO"
- +3 SET PPTR=+$PIECE($GET(^PSRX(PSRXIEN,"OR1")),"^")
- +4 SET FIELD(1)=$SELECT('PPTR:"^^^^^",1:"^^^"_PPTR_"^"_$PIECE($GET(^PS(50.7,PPTR,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")_"^99PSP")
- +5 ;*441-IND
- SET $PIECE(FIELD(1),"|",20)=$PIECE($GET(^PSRX(PSRXIEN,"IND")),"^")
- +6 DO SEG
- QUIT
- +7 ;
- RXE ;
- +1 SET RXE2FLAG=1
- +2 SET LIMIT=$SELECT('$GET(RXE2ONLY):26,1:2)
- XECUTE NULLFLDS
- +3 SET FIELD(0)="RXE"
- +4 SET (PSOHSTRT,PSOHSTOP)=""
- SET X=$PIECE($GET(^PSRX(PSRXIEN,2)),"^",2)
- IF X
- SET PSOHSTRT=$$FMTHL7^XLFDT(X)
- +5 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +6 SET X=$SELECT($PIECE($GET(^PSRX(PSRXIEN,3)),"^",5):$PIECE($GET(^(3)),"^",5),$GET(STAT)="OD"!($GET(STAT)="OC"):$GET(DT),$PIECE($GET(^(2)),"^",6):$PIECE($GET(^(2)),"^",6),1:$GET(DT))
- IF X
- SET PSOHSTOP=$$FMTHL7^XLFDT(X)
- +7 KILL X
- NEW PSOMZT,MMZZ,MMZZT
- SET MMZZT=1
- FOR MMZZ=0:0
- SET MMZZ=$ORDER(^PSRX(PSRXIEN,6,MMZZ))
- if 'MMZZ
- QUIT
- if $DATA(^(MMZZ,0))
- Begin DoDot:1
- +8 SET FIELD(1,MMZZT)=$SELECT($PIECE($GET(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2):$$ESC^ORHLESC($PIECE($GET(^(0)),"^"))_"\T\"_$PIECE($GET(^PS(50.607,+$PIECE($GET(^(0)),"^",3),0)),"^")_"\T\"_$PIECE(...
- ... $GET(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2)_"\T\"_$PIECE($GET(^(0)),"^",4),1:"")
- +9 SET FIELD(1,MMZZT)=FIELD(1,MMZZT)_"^"_$$ESC^ORHLESC($PIECE($GET(^PSRX(PSRXIEN,6,MMZZ,0)),"^",8))
- +10 IF $PIECE($GET(FIELD(1,MMZZT)),"^")'=""
- FOR PSOMZT=1,3
- IF $EXTRACT($PIECE(FIELD(1,MMZZT),"\T\",PSOMZT),1)="."
- SET $PIECE(FIELD(1,MMZZT),"\T\",PSOMZT)="0"_$PIECE(FIELD(1,MMZZT),"\T\",PSOMZT)
- +11 SET FIELD(1,MMZZT)=$GET(FIELD(1,MMZZT))_"^"_$$DUR(PSRXIEN,MMZZ)_"^^^^^"_$SELECT($PIECE($GET(FIELD(1,MMZZT)),"^")'="":$PIECE($GET(FIELD(1,MMZZT)),"\T\")_$PIECE($GET(FIELD(1,MMZZT)),"\T\",2),1:$PIECE($GET(^PSRX(PSRXIEN,6,MMZZ,0)),"^")
- )
- +12 SET FIELD(1,MMZZT)=$GET(FIELD(1,MMZZT))_"^"_$PIECE($GET(^PSRX(PSRXIEN,6,MMZZ,0)),"^",6)
- +13 IF $ORDER(^PSRX(PSRXIEN,6,MMZZ))
- SET FIELD(1,MMZZT)=$GET(FIELD(1,MMZZT))_"~"
- +14 SET MMZZT=MMZZT+1
- End DoDot:1
- +15 SET $PIECE(FIELD(1,1),"^",4)=$GET(PSOHSTRT)
- SET $PIECE(FIELD(1,$SELECT(MMZZT>1:MMZZT-1,1:1)),"^",5)=$GET(PSOHSTOP)
- +16 SET PSFLAG=0
- SET PSDIEN=+$PIECE(^PSRX(PSRXIEN,0),"^",6)
- SET PSND1=$PIECE($GET(^PSDRUG(PSDIEN,"ND")),"^")
- SET PSND2=$PIECE($GET(^("ND")),"^",2)
- SET PSND3=$PIECE($GET(^("ND")),"^",3)
- IF PSND1
- IF PSND3
- SET PSFLAG=1
- +17 SET FIELD(2)=$SELECT(PSFLAG:PSND1_"."_PSND3_"^"_$$ESC^ORHLESC(PSND2)_"^"_"99NDF",1:"^^")_"^"_PSDIEN_"^"_$$ESC^ORHLESC($PIECE($GET(^PSDRUG(PSDIEN,0)),"^"))_"^"_"99PSD"
- +18 if $GET(RXE2ONLY)
- QUIT
- +19 IF PSFLAG
- Begin DoDot:1
- +20 IF $TEXT(^PSNAPIS)]""
- SET PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3)
- SET FIELD(5)="^^^"_$PIECE($GET(PSOXN),"^",5)_"^"_$$ESC^ORHLESC($PIECE($GET(PSOXN),"^",6))_"^"_"99PSU"
- KILL PSOXN
- QUIT
- +21 SET PRODUCT=$GET(^PSNDF(PSND1,5,PSND3,0))
- SET UNIT=$PIECE($GET(^PSNDF(PSND1,2,+$PIECE(PRODUCT,"^",2),3,+$PIECE(PRODUCT,"^",3),4,+$PIECE(PRODUCT,"^",4),0)),"^")
- +22 SET FIELD(5)="^^^"_UNIT_"^"_$$ESC^ORHLESC($PIECE($GET(^PS(50.607,+UNIT,0)),"^"))_"^"_"99PSU"
- End DoDot:1
- +23 SET POIPTR=$PIECE($GET(^PSRX(PSRXIEN,"OR1")),"^")
- IF POIPTR
- SET PODOSE=$PIECE($GET(^PS(50.7,POIPTR,0)),"^",2)
- SET PODOSENM=$PIECE($GET(^PS(50.606,+PODOSE,0)),"^")
- +24 IF POIPTR
- SET FIELD(6)="^^^"_$GET(PODOSE)_"^"_$$ESC^ORHLESC($GET(PODOSENM))_"^"_"99PSF"
- +25 SET FIELD(10)=$PIECE(^PSRX(PSRXIEN,0),"^",7)
- +26 SET FIELD(12)=$PIECE(^PSRX(PSRXIEN,0),"^",9)
- +27 ;*545 - set RXE with the selected DEA#
- +28 IF $GET(PSRXIEN)
- IF $DATA(^TMP("PSORXN",$JOB,PSRXIEN,"DEA"))
- SET FIELD(13)=^TMP("PSORXN",$JOB,PSRXIEN,"DEA")
- +29 SET FIELD(14)=$PIECE(^PSRX(PSRXIEN,0),"^",4)
- +30 SET FIELD(15)=$PIECE(^PSRX(PSRXIEN,0),"^")
- +31 SET FIELD(22)=$PIECE(^PSRX(PSRXIEN,0),"^",8)
- +32 KILL MMZZ
- SET MMZZ=$$EN^PSSUTIL1(PSDIEN)
- SET FIELD(25)=$SELECT($EXTRACT($PIECE(MMZZ,"|"),1)=".":"0",1:"")_$PIECE(MMZZ,"|")
- SET FIELD(26)=$PIECE(MMZZ,"|",2)
- +33 NEW PLIM,PVAR,PVAR1,SUBCOUNT
- DO SEGPARX^PSOHLSN
- +34 ;
- +35 IF $ORDER(^PSRX(PSRXIEN,"PRC",0))
- Begin DoDot:1
- +36 SET COUNT=COUNT+1
- SET CCC=$ORDER(^PSRX(PSRXIEN,"PRC",0))
- +37 SET MSG(COUNT)="NTE|6||"_$$ESC^ORHLESC($GET(^PSRX(PSRXIEN,"PRC",CCC,0)))
- +38 SET CSCOUNT=1
- FOR CCC=CCC:0
- SET CCC=$ORDER(^PSRX(PSRXIEN,"PRC",CCC))
- if 'CCC
- QUIT
- SET MSG(COUNT,CSCOUNT)=$$ESC^ORHLESC($GET(^PSRX(PSRXIEN,"PRC",CCC,0)))
- SET CSCOUNT=CSCOUNT+1
- End DoDot:1
- +39 IF $ORDER(^PSRX(PSRXIEN,"INS1",0))
- Begin DoDot:1
- +40 SET COUNT=COUNT+1
- SET CCC=$ORDER(^PSRX(PSRXIEN,"INS1",0))
- +41 SET MSG(COUNT)="NTE|7|L|"_$$ESC^ORHLESC($GET(^PSRX(PSRXIEN,"INS1",CCC,0)))
- +42 SET CCCX=1
- FOR
- SET CCC=$ORDER(^PSRX(PSRXIEN,"INS1",CCC))
- if 'CCC
- QUIT
- IF $DATA(^PSRX(PSRXIEN,"INS1",CCC,0))
- SET MSG(COUNT,CCCX)=$$ESC^ORHLESC($GET(^(0)))
- SET CCCX=CCCX+1
- End DoDot:1
- +43 SET COUNT=COUNT+1
- +44 IF $PIECE($GET(^PSRX(PSRXIEN,"SIG")),"^",2)
- Begin DoDot:1
- +45 DO FSIG^PSOUTLA("R",PSRXIEN,238)
- SET MSG(COUNT)="NTE|21||"_$SELECT($GET(FSIG(1))'="":$$ESC^ORHLESC($GET(FSIG(1))),1:"No SIG available")
- IF $ORDER(FSIG(1))
- FOR CCC=1:0
- SET CCC=$ORDER(FSIG(CCC))
- if 'CCC
- QUIT
- SET MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($GET(FSIG(CCC)))
- End DoDot:1
- QUIT
- +46 IF '$PIECE($GET(^PSRX(PSRXIEN,"SIG")),"^",2)
- Begin DoDot:1
- +47 DO EN3^PSOUTLA1(PSRXIEN,238)
- SET MSG(COUNT)="NTE|21||"_$SELECT($GET(BSIG(1))'="":$$ESC^ORHLESC($GET(BSIG(1))),1:"No SIG available")
- IF $ORDER(BSIG(1))
- FOR CCC=1:0
- SET CCC=$ORDER(BSIG(CCC))
- if 'CCC
- QUIT
- SET MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($GET(BSIG(CCC)))
- End DoDot:1
- QUIT
- +48 QUIT
- +49 ;
- RXR ;
- +1 FOR PSORTLP=0:0
- SET PSORTLP=$ORDER(^PSRX(PSRXIEN,6,PSORTLP))
- if 'PSORTLP
- QUIT
- Begin DoDot:1
- +2 SET LIMIT=1
- XECUTE NULLFLDS
- +3 SET FIELD(0)="RXR"
- +4 SET PSROUTE=$PIECE($GET(^PSRX(PSRXIEN,6,PSORTLP,0)),"^",7)
- IF PSROUTE
- IF $DATA(^PS(51.2,PSROUTE,0))
- SET RTNAME=$PIECE(^PS(51.2,PSROUTE,0),"^")
- +5 SET FIELD(1)="^^^"_$GET(PSROUTE)_"^"_$GET(RTNAME)_"^"_"99PSR"
- +6 DO SEG
- End DoDot:1
- +7 QUIT
- +8 ;
- ZCL DO ZCL^PSOHLSN2
- +1 QUIT
- ZSC DO ZSC^PSOHLSN2
- +1 QUIT
- +2 ;
- ZRX ;
- +1 SET ZRXFLAG=1
- +2 SET LIMIT=8
- XECUTE NULLFLDS
- +3 SET FIELD(0)="ZRX"
- +4 SET ZPRE=$PIECE($GET(^PSRX(PSRXIEN,"OR1")),"^",3)
- IF ZPRE
- SET FIELD(1)=$PIECE($GET(^PSRX(ZPRE,"OR1")),"^",2)
- +5 IF '$GET(FIELD(1))
- IF $GET(PSORDEDT)
- SET FIELD(1)=$PIECE($GET(^PS(52.41,$GET(PSORDEDT),0)),"^")
- +6 SET FIELD(2)=$GET(PSNOO)
- +7 IF $GET(STAT)="SN"!($GET(STAT)="RO")
- SET FIELD(3)=$SELECT($GET(STAT)="RO"!($GET(PSOEDIT)):"E",$GET(PSOOPT)=3:"R",1:"N")
- +8 SET FIELD(4)=$PIECE(^PSRX(PSRXIEN,0),"^",11)
- +9 SET PSOCDDUZ=$SELECT($GET(PSOROPCH)="PATCH":$PIECE($GET(^PSRX(PSRXIEN,"OR1")),"^",5),$GET(PSOHUIOR)&($PIECE($GET(^PSRX(PSRXIEN,"EXT")),"^")'=""):+$GET(PSOCANRC),1:$GET(DUZ))
- +10 IF $GET(PSOCDDUZ)
- SET FIELD(5)=PSOCDDUZ_"^"_$PIECE($GET(^VA(200,PSOCDDUZ,0)),"^")_"^"_"99NP"
- +11 IF $GET(STAT)="ZD"
- IF $GET(PSODISPP)
- SET FIELD(6)="P"
- +12 SET FIELD(8)=$PIECE($GET(^PSRX(PSRXIEN,"TIT")),"^",3)
- +13 DO SEG
- QUIT
- 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 if $GET(PSRXIEN)&($TEXT(EN^PSOHDR)]"")&($GET(PSOSSMES)'="CPRSUP")
- Begin DoDot:1
- +1 IF $GET(STAT)="ZC"!($GET(STAT)="UC")!($GET(STAT)="UD")!($GET(STAT)="UH")!($GET(STAT)="UR")!($GET(STAT)="DE")!($GET(STAT)="ZD")!($GET(STAT)="SN")!($GET(STAT)="Z@")
- QUIT
- +2 IF $GET(STAT)="SC"
- IF $GET(PSSTAT)="ZZ"
- QUIT
- +3 DO EN^PSOHDR("PRES",PSRXIEN)
- End DoDot:1
- KILL FIELD
- DO MSG^XQOR("PS EVSEND OR",.MSG)
- QUIT
- +4 ;
- NOO ;
- +1 IF $GET(PSNOO)=""
- SET PSNOOTX=""
- QUIT
- +2 SET PSNOOTX=$SELECT(PSNOO="W":"Written",PSNOO="V":"Verbal",PSNOO="P":"Telephoned",PSNOO="S":"Service Correction",PSNOO="X":"Rejected",PSNOO="D":"Duplicate",PSNOO="I":"Policy",PSNOO="E":"Physician Entered",PSNOO="A":"Auto DC",1:"")
- QUIT
- +3 QUIT
- +4 ;
- DUR(PSODX1,PSODX2) ;
- +1 NEW PSODX,PSODX4,PSODX5,PSODX6,PSODX7
- SET PSODX=$PIECE($GET(^PSRX(PSODX1,6,PSODX2,0)),"^",5)
- +2 IF 'PSODX
- QUIT PSODX
- +3 SET PSODX4=$LENGTH(PSODX)
- SET PSODX5=$EXTRACT(PSODX,PSODX4)
- +4 SET PSODX=$SELECT(PSODX5?1A:PSODX,1:PSODX_"D")
- +5 SET PSODX6=$LENGTH(PSODX)
- +6 SET PSODX7=$EXTRACT(PSODX,PSODX6)_$EXTRACT(PSODX,1,(PSODX6-1))
- +7 QUIT PSODX7
- +8 QUIT