PSDDSOR1 ;BHM/MHA/PWC - Digitally signed CS Orders Report ;02/02/2021
;;3.0;CONTROLLED SUBSTANCES;**40,67,73,83,89,94**;Feb 13,1997;Build 4
;Ref. to ^PSRX( supported by DBIA 1977
;Ref. to ^PS(52.41, supported by DBIA 3848
;Ref. to ^PSOERXU9 supported by ICR/IA 7222
;
Q
PRT ; Print the Report
N ERXIEN S ERXIEN=$$ERXIEN^PSOERXU9($S(AC=4:S5_"P",1:S5))
I ($Y+13)>IOSL D:AC HD^PSDDSOR D:'AC HD^PSDDSOR2 Q:$D(DIRUT)
; PSD*3*83 - newing variables to clean up XINDEX
N I,PL,PL1,J
S I=0,PL=""
I $P($G(Y2),"^")]"" S PL=$E($P(Y2,"^"),1,30)
E S PL=$E($P($G(Y6),"^"),1,30),I=1
W !?1," DRUG"_$S($G(I):" (OI)",1:"")_": "_PL,?50,"CS ",$S('ERXIEN:"Federal ",1:""),"Schedule: "_+$P(Y2,"^",5) ;PSD-89
F I=1:1 Q:'$G(Y7(I)) W " ",Y7(I),!
W !?2,"Provider: "_$E($P(Y4,"^")_P1,1,30),?50,"DEA #: "_$P(Y4,"^",3)
W !?2,"Clinic: "_$S(ERXIEN:"",1:$$GET1^DIQ(44,$P(Y0,"^",13),.01))
;W ?50,"Detox #: "_$S(ERXIEN:"",1:$P(Y4,"^",4)) ; PSD-89 ; PSD-94
S PL=$P(Y5,"^"),PL1="" F I=2:1:6 S J=$P(Y5,"^",I) D:J]""
.I PL1="",$L(J)+$L(PL)<60 S PL=$S(PL'="":PL_", "_J,1:J)
.E S PL1=PL1_$S(PL1]"":", ",1:"")_J
W !?2,"Provider Address: "_PL W:PL1]"" !?20,PL1
W !?2,"CPRS Order #: "_$S(ERXIEN:"N/A",1:$P(Y0,"^",2)),?50,"Date Order Written: " S Y=$P(Y0,"^",5) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) ;PSD-89
W !?2,"Patient Name: "_$E($P(Y1,"^")_P1,1,30)
I 'ERXIEN D ;PSD-89
. W ?50,"PATIENT ID: "
. S DFN=$S($P(Y0,"^",12)="R":$P(^PSRX(S5,0),"^",2),1:$P($G(^PS(52.41,S5,0)),"^",2)) D PID^VADPT W $E($P(Y1,"^"))_VA("BID")
E D
. W ?50,"DOB: ",$P(Y1,U,8)
S PL=$P(Y1,"^",2),PL1="" F I=3:1:7 S J=$P(Y1,"^",I) D:J]""
.I PL1="",$L(J)+$L(PL)<60 S PL=PL_", "_J
.E S PL1=PL1_$S(PL1]"":", ",1:"")_J
W !?2,"Patient Address: "_PL W:PL1]"" !?19,PL1
W !?2,"Rx #: "_$S($P(Y0,"^",12)="R":$P(^PSRX(S5,0),"^"),1:"")
W !?2,"eRx ID #: "_$S(ERXIEN:$P(Y2,"^",6),1:"") ;PSD-89
;PATCH PSD*3*83 - Added ECME# to be displayed on report
I $D(Y8) W !?2,"ECME #: "_Y8
W ?50,"Qty: "_$S(AC=4:$P(^PS(52.41,S5,0),"^",10),1:$P(Y2,"^",3))
W !?2,"SIG: "
D FSIG($P(Y0,"^",12),S5,75)
I $G(FSIG(1))'="" D
. W $$UNESC^ORHLESC($G(FSIG(1)))
. I $O(FSIG(1)) D
. . F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE D
. . . W !?6,$$UNESC^ORHLESC($G(FSIG(EE)))
F S PL=$O(Y3(PL)) Q:'PL W ?7,Y3(PL),!
P1 N RX2 S RX2=$S($P(Y0,"^",12)="R":$G(^PSRX(S5,2)),1:"")
W !?2,"Date Filled: ",$$FMTE^XLFDT($P(RX2,"^",2),"2Z")
W ?27,"# of Refills: ",$S($P(Y0,"^",12)="R":+$P($G(^PSRX(S5,0)),"^",9),1:$P($G(^PS(52.41,S5,0)),"^",11))
W ?50,"Date Released: " S Y=$P(RX2,"^",13) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
W !?2,"Releasing Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
W ?50,"Valid PKI Certificate?: ",$S(ERXIEN:"N/A",$$GET1^DIQ(52,S5,310,"I"):"Yes",1:"") ;PSD-89
W !?2,"Date Signature Validation Attempted by Pharmacy: " W:ERXIEN "N/A"
I 'ERXIEN,AC'=4,$$GET1^DIQ(52,S5,310,"I"),Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) ;PSD-89, only CPRS entered Rx's will have date
W !?2,$S('ERXIEN:"CPRS ",1:"")_"Nature of Order: "_$P(Y0,"^",3),?50,"Order Status: "_$P($P(Y0,"^",4),";",2) ;PSD-89
S PL=$S(ERXIEN!(AC=4)!(AC'=4&$$GET1^DIQ(52,S5,310,"I")):"Digitally Signed",1:"") ;PSD-89
W !?2,"Signature Status: "_$E(PL,1,60) W:$L(PL)>60 !,?20,$E(PL,61,200) W !
Q
;
GETDATA(Y,ORIEN,DFN) ;Gets data from archival file, otherwise use old CPRS call.
;Input: ORIEN - Order IEN
; DFN - Patient IEN
;Output Y
;On error: Y = -1^Error message
;Else: Y = 1^ Order # ^ Nature of order ^ Order Status ^ Date Signed
; Y(1) = "Patient name ^ Street1 ^ Street2 ^ Street3 ^ City ^ State ^ Zip"
; Y(2) = "Drug name_strength_dosage form (Dispense drug) ^ Drug IEN (file 50) ^ Drug quantity prescribed ^ Schedule of medication ^5 DEA Schedule"
; Y(3) = "Directions for use (SIG)"
; Y(4) = "Provider's name ^ DUZ ^ Provider's DEA # ^" ;; Provider's DETOX # removed by PSD*3*94
; Y(5) = "SiteName ^ SiteStreet1 ^ SiteStreet2 ^ SiteCity ^ SiteState ^ SiteZip"
; Y(6) = "Orderable Item ^ Orderable Item IEN (file 50.7)"
; Y(7) = "Strength ^ Dosage Form
N TMP,PND0,RX0,DDR,ECME,RFL,CN,EE,RXIEN,RX0,RXOI,PIEN,ORI,ORIE,STA,ERXIEN
N ERXDATA
I $G(ORIEN)="" S Y="-1^INVALID ORDER #" Q
I $G(DFN)="" S Y="-1^INVALID PATIENT ID" Q
S ERXIEN=+$$CHKERX^PSOERXU9(ORIEN)
K ^TMP($J,"ORDEA")
I 'ERXIEN D
. D ARCHIVE^ORDEA(ORIEN)
. I $D(^TMP($J,"ORDEA",ORIEN,1)),'$P(^(1),"^"),'$G(PND) N NCHK S NCHK=0 D I 'NCHK S Y="-1^INVALID PRESCRIPTION #" Q
. . S NCHK=$$SUBSCRIB^ORDEA(ORIEN,RX)
. . I NCHK K ^TMP($J,"ORDEA") D ARCHIVE^ORDEA(ORIEN)
E D ; eRx Prescription
. D ERXDATA^PSOERXU9(.ERXDATA,ERXIEN)
;
I 'ERXIEN,'$D(^TMP($J,"ORDEA")) D GETDATA^ORWOR1(.Y,ORIEN,DFN) Q
I 'ERXIEN D ;PSD-89
. M TMP=^TMP($J,"ORDEA",ORIEN)
E D
. M TMP=ERXDATA
I 'ERXIEN,DFN'=$P(TMP(4),"^",2) S Y="-1^INVALID PATIENT ID" Q
S RXIEN=$O(^PSRX("APL",ORIEN,"")),RX0=$S(RXIEN:$G(^PSRX(RXIEN,0)),1:""),RXOI=$S(RXIEN:$G(^PSRX(RXIEN,"OR1")),1:"")
S PIEN=$O(^PS(52.41,"B",ORIEN,"")),PND0=$S(PIEN:$G(^PS(52.41,PIEN,0)),1:"")
I 'ERXIEN,RXIEN="",PIEN="" S Y="-1^INVALID ORDER #" Q
I 'ERXIEN,RXIEN'="",RXIEN'=$P(TMP(1),"^") S Y="-1^INVALID PRESCRIPTION #" Q
S DDR=$P(RX0,"^",6) S:DDR DDR=$$GET1^DIQ(50,DDR,.01)_"^"_DDR
S STA=$S(RXIEN:$P($G(^PSRX(RXIEN,"STA")),"^")_";"_$$GET1^DIQ(52,RXIEN,100),1:99_";"_$$GET1^DIQ(52.41,PIEN,2))
;
N NATURE S NATURE=$S(ERXIEN:"ELECTRONICALLY RECEIVED",1:$P($$NATURE^ORUTL3(ORIEN),"^",3)) ;PSD-89
S Y="1^"_ORIEN_"^"_NATURE_"^"_STA_"^"_$P(TMP(1),"^",2) ;PSD-89
S Y(1)=$P(TMP(4),"^")_"^"_TMP(5)
S Y(2)=$S($P(TMP(1),"^",3)'="":$P(TMP(1),"^",3,4),DDR'="":DDR,1:"^")_"^"_$P(TMP(1),"^",6)_"^^"_$P(TMP(1),"^",5)_U_$P(TMP(1),U,8)
S Y(3)="" M Y(3)=TMP(6)
S Y(4)=$P(TMP(2),"^",3)_"^"_$P(TMP(2),"^",4)_"^"_$P(TMP(2),"^",1,2)
S Y(5)=TMP(3)
S ORI=$S($P(RXOI,"^"):$P(RXOI,"^"),1:$P(PND0,"^",8))
S ORIE=$S($D(^PS(50.7,ORI,0)):$P(^PS(50.7,ORI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")
S Y(6)=ORIE_"^"_ORI
S CN=$O(TMP(7,"")) I CN'="" S $P(Y(2),"^")=$P(Y(2),"^")_" "_$TR(TMP(7,CN),"^"," ")
S Y(7)="" M Y(7)=TMP(7) I CN'="" K Y(7,CN)
S $P(Y,"^",10)=1
;PATCH PSD*3*83 - Added functionality to add the ECME # to the Y array
I RXIEN D
.S RFL=$$LSTRFL^PSOBPSU1(RXIEN)
.S ECME=$$ECMENUM^PSOBPSU2(RXIEN,RFL)
.S Y(8)=ECME
Q
;
FSIG(PSOFILE,PSOINTR,PSOLENTH) ;Format front door sig
;PSOFILE is 'P' if in Pending File, 'R' if in Prescription File
;PSOINTR is internal number for either file
;PSOLENTH is length of each line of the Sig
;returned in the FSIG array
K FSIG I $G(PSOFILE)=""!('$G(PSOINTR))!('$G(PSOLENTH)) G FQUIT
I PSOFILE'="P",PSOFILE'="R" G FQUIT
I PSOFILE="P",'$D(^PS(52.41,+PSOINTR,0)) G FQUIT
I PSOFILE="R",'$D(^PSRX(+PSOINTR,0)) G FQUIT
I PSOFILE="R",'$P($G(^PSRX(+PSOINTR,"SIG")),"^",2) G FQUIT
N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
I PSOFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSOINTR,"SIG",NNN)) Q:'NNN S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
I PSOFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
S FFF=1 F NNN=0:0 S NNN=$O(^PSRX(PSOINTR,"SIG1",NNN)) Q:'NNN I $G(^(NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
G:'$O(HSIG(0)) FQUIT
FSTART S (FVAR,FVAR1)="",II=1
F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D I $L(FVAR)>PSOLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
.S FVAR1=$P(HSIG(FFF)," ",(CNT))
.S FLIM=FVAR
.S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
I $G(FVAR)'="" S FSIG(II)=FVAR
I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
FQUIT Q
;
SIG(RXIEN) ; Directions
N SIG,I S SIG=""
I $G(RXIEN) D
. F I=1:1 Q:'$D(^PSRX(RXIEN,"SIG1",I)) D
. . S SIG=SIG_$G(^PSRX(RXIEN,"SIG1",I,0))
Q SIG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDSOR1 7780 printed Dec 13, 2024@01:45:32 Page 2
PSDDSOR1 ;BHM/MHA/PWC - Digitally signed CS Orders Report ;02/02/2021
+1 ;;3.0;CONTROLLED SUBSTANCES;**40,67,73,83,89,94**;Feb 13,1997;Build 4
+2 ;Ref. to ^PSRX( supported by DBIA 1977
+3 ;Ref. to ^PS(52.41, supported by DBIA 3848
+4 ;Ref. to ^PSOERXU9 supported by ICR/IA 7222
+5 ;
+6 QUIT
PRT ; Print the Report
+1 NEW ERXIEN
SET ERXIEN=$$ERXIEN^PSOERXU9($SELECT(AC=4:S5_"P",1:S5))
+2 IF ($Y+13)>IOSL
if AC
DO HD^PSDDSOR
if 'AC
DO HD^PSDDSOR2
if $DATA(DIRUT)
QUIT
+3 ; PSD*3*83 - newing variables to clean up XINDEX
+4 NEW I,PL,PL1,J
+5 SET I=0
SET PL=""
+6 IF $PIECE($GET(Y2),"^")]""
SET PL=$EXTRACT($PIECE(Y2,"^"),1,30)
+7 IF '$TEST
SET PL=$EXTRACT($PIECE($GET(Y6),"^"),1,30)
SET I=1
+8 ;PSD-89
WRITE !?1," DRUG"_$SELECT($GET(I):" (OI)",1:"")_": "_PL,?50,"CS ",$SELECT('ERXIEN:"Federal ",1:""),"Schedule: "_+$PIECE(Y2,"^",5)
+9 FOR I=1:1
if '$GET(Y7(I))
QUIT
WRITE " ",Y7(I),!
+10 WRITE !?2,"Provider: "_$EXTRACT($PIECE(Y4,"^")_P1,1,30),?50,"DEA #: "_$PIECE(Y4,"^",3)
+11 WRITE !?2,"Clinic: "_$SELECT(ERXIEN:"",1:$$GET1^DIQ(44,$PIECE(Y0,"^",13),.01))
+12 ;W ?50,"Detox #: "_$S(ERXIEN:"",1:$P(Y4,"^",4)) ; PSD-89 ; PSD-94
+13 SET PL=$PIECE(Y5,"^")
SET PL1=""
FOR I=2:1:6
SET J=$PIECE(Y5,"^",I)
if J]""
Begin DoDot:1
+14 IF PL1=""
IF $LENGTH(J)+$LENGTH(PL)<60
SET PL=$SELECT(PL'="":PL_", "_J,1:J)
+15 IF '$TEST
SET PL1=PL1_$SELECT(PL1]"":", ",1:"")_J
End DoDot:1
+16 WRITE !?2,"Provider Address: "_PL
if PL1]""
WRITE !?20,PL1
+17 ;PSD-89
WRITE !?2,"CPRS Order #: "_$SELECT(ERXIEN:"N/A",1:$PIECE(Y0,"^",2)),?50,"Date Order Written: "
SET Y=$PIECE(Y0,"^",5)
IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+18 WRITE !?2,"Patient Name: "_$EXTRACT($PIECE(Y1,"^")_P1,1,30)
+19 ;PSD-89
IF 'ERXIEN
Begin DoDot:1
+20 WRITE ?50,"PATIENT ID: "
+21 SET DFN=$SELECT($PIECE(Y0,"^",12)="R":$PIECE(^PSRX(S5,0),"^",2),1:$PIECE($GET(^PS(52.41,S5,0)),"^",2))
DO PID^VADPT
WRITE $EXTRACT($PIECE(Y1,"^"))_VA("BID")
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 WRITE ?50,"DOB: ",$PIECE(Y1,U,8)
End DoDot:1
+24 SET PL=$PIECE(Y1,"^",2)
SET PL1=""
FOR I=3:1:7
SET J=$PIECE(Y1,"^",I)
if J]""
Begin DoDot:1
+25 IF PL1=""
IF $LENGTH(J)+$LENGTH(PL)<60
SET PL=PL_", "_J
+26 IF '$TEST
SET PL1=PL1_$SELECT(PL1]"":", ",1:"")_J
End DoDot:1
+27 WRITE !?2,"Patient Address: "_PL
if PL1]""
WRITE !?19,PL1
+28 WRITE !?2,"Rx #: "_$SELECT($PIECE(Y0,"^",12)="R":$PIECE(^PSRX(S5,0),"^"),1:"")
+29 ;PSD-89
WRITE !?2,"eRx ID #: "_$SELECT(ERXIEN:$PIECE(Y2,"^",6),1:"")
+30 ;PATCH PSD*3*83 - Added ECME# to be displayed on report
+31 IF $DATA(Y8)
WRITE !?2,"ECME #: "_Y8
+32 WRITE ?50,"Qty: "_$SELECT(AC=4:$PIECE(^PS(52.41,S5,0),"^",10),1:$PIECE(Y2,"^",3))
+33 WRITE !?2,"SIG: "
+34 DO FSIG($PIECE(Y0,"^",12),S5,75)
+35 IF $GET(FSIG(1))'=""
Begin DoDot:1
+36 WRITE $$UNESC^ORHLESC($GET(FSIG(1)))
+37 IF $ORDER(FSIG(1))
Begin DoDot:2
+38 FOR EE=1:0
SET EE=$ORDER(FSIG(EE))
if 'EE
QUIT
Begin DoDot:3
+39 WRITE !?6,$$UNESC^ORHLESC($GET(FSIG(EE)))
End DoDot:3
End DoDot:2
End DoDot:1
+40 FOR
SET PL=$ORDER(Y3(PL))
if 'PL
QUIT
WRITE ?7,Y3(PL),!
P1 NEW RX2
SET RX2=$SELECT($PIECE(Y0,"^",12)="R":$GET(^PSRX(S5,2)),1:"")
+1 WRITE !?2,"Date Filled: ",$$FMTE^XLFDT($PIECE(RX2,"^",2),"2Z")
+2 WRITE ?27,"# of Refills: ",$SELECT($PIECE(Y0,"^",12)="R":+$PIECE($GET(^PSRX(S5,0)),"^",9),1:$PIECE($GET(^PS(52.41,S5,0)),"^",11))
+3 WRITE ?50,"Date Released: "
SET Y=$PIECE(RX2,"^",13)
IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+4 WRITE !?2,"Releasing Pharmacist: "_$SELECT($PIECE(RX2,"^",3):$PIECE(^VA(200,$PIECE(RX2,"^",3),0),"^"),1:"")
+5 ;PSD-89
WRITE ?50,"Valid PKI Certificate?: ",$SELECT(ERXIEN:"N/A",$$GET1^DIQ(52,S5,310,"I"):"Yes",1:"")
+6 WRITE !?2,"Date Signature Validation Attempted by Pharmacy: "
if ERXIEN
WRITE "N/A"
+7 ;PSD-89, only CPRS entered Rx's will have date
IF 'ERXIEN
IF AC'=4
IF $$GET1^DIQ(52,S5,310,"I")
IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+8 ;PSD-89
WRITE !?2,$SELECT('ERXIEN:"CPRS ",1:"")_"Nature of Order: "_$PIECE(Y0,"^",3),?50,"Order Status: "_$PIECE($PIECE(Y0,"^",4),";",2)
+9 ;PSD-89
SET PL=$SELECT(ERXIEN!(AC=4)!(AC'=4&$$GET1^DIQ(52,S5,310,"I")):"Digitally Signed",1:"")
+10 WRITE !?2,"Signature Status: "_$EXTRACT(PL,1,60)
if $LENGTH(PL)>60
WRITE !,?20,$EXTRACT(PL,61,200)
WRITE !
+11 QUIT
+12 ;
GETDATA(Y,ORIEN,DFN) ;Gets data from archival file, otherwise use old CPRS call.
+1 ;Input: ORIEN - Order IEN
+2 ; DFN - Patient IEN
+3 ;Output Y
+4 ;On error: Y = -1^Error message
+5 ;Else: Y = 1^ Order # ^ Nature of order ^ Order Status ^ Date Signed
+6 ; Y(1) = "Patient name ^ Street1 ^ Street2 ^ Street3 ^ City ^ State ^ Zip"
+7 ; Y(2) = "Drug name_strength_dosage form (Dispense drug) ^ Drug IEN (file 50) ^ Drug quantity prescribed ^ Schedule of medication ^5 DEA Schedule"
+8 ; Y(3) = "Directions for use (SIG)"
+9 ; Y(4) = "Provider's name ^ DUZ ^ Provider's DEA # ^" ;; Provider's DETOX # removed by PSD*3*94
+10 ; Y(5) = "SiteName ^ SiteStreet1 ^ SiteStreet2 ^ SiteCity ^ SiteState ^ SiteZip"
+11 ; Y(6) = "Orderable Item ^ Orderable Item IEN (file 50.7)"
+12 ; Y(7) = "Strength ^ Dosage Form
+13 NEW TMP,PND0,RX0,DDR,ECME,RFL,CN,EE,RXIEN,RX0,RXOI,PIEN,ORI,ORIE,STA,ERXIEN
+14 NEW ERXDATA
+15 IF $GET(ORIEN)=""
SET Y="-1^INVALID ORDER #"
QUIT
+16 IF $GET(DFN)=""
SET Y="-1^INVALID PATIENT ID"
QUIT
+17 SET ERXIEN=+$$CHKERX^PSOERXU9(ORIEN)
+18 KILL ^TMP($JOB,"ORDEA")
+19 IF 'ERXIEN
Begin DoDot:1
+20 DO ARCHIVE^ORDEA(ORIEN)
+21 IF $DATA(^TMP($JOB,"ORDEA",ORIEN,1))
IF '$PIECE(^(1),"^")
IF '$GET(PND)
NEW NCHK
SET NCHK=0
Begin DoDot:2
+22 SET NCHK=$$SUBSCRIB^ORDEA(ORIEN,RX)
+23 IF NCHK
KILL ^TMP($JOB,"ORDEA")
DO ARCHIVE^ORDEA(ORIEN)
End DoDot:2
IF 'NCHK
SET Y="-1^INVALID PRESCRIPTION #"
QUIT
End DoDot:1
+24 ; eRx Prescription
IF '$TEST
Begin DoDot:1
+25 DO ERXDATA^PSOERXU9(.ERXDATA,ERXIEN)
End DoDot:1
+26 ;
+27 IF 'ERXIEN
IF '$DATA(^TMP($JOB,"ORDEA"))
DO GETDATA^ORWOR1(.Y,ORIEN,DFN)
QUIT
+28 ;PSD-89
IF 'ERXIEN
Begin DoDot:1
+29 MERGE TMP=^TMP($JOB,"ORDEA",ORIEN)
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 MERGE TMP=ERXDATA
End DoDot:1
+32 IF 'ERXIEN
IF DFN'=$PIECE(TMP(4),"^",2)
SET Y="-1^INVALID PATIENT ID"
QUIT
+33 SET RXIEN=$ORDER(^PSRX("APL",ORIEN,""))
SET RX0=$SELECT(RXIEN:$GET(^PSRX(RXIEN,0)),1:"")
SET RXOI=$SELECT(RXIEN:$GET(^PSRX(RXIEN,"OR1")),1:"")
+34 SET PIEN=$ORDER(^PS(52.41,"B",ORIEN,""))
SET PND0=$SELECT(PIEN:$GET(^PS(52.41,PIEN,0)),1:"")
+35 IF 'ERXIEN
IF RXIEN=""
IF PIEN=""
SET Y="-1^INVALID ORDER #"
QUIT
+36 IF 'ERXIEN
IF RXIEN'=""
IF RXIEN'=$PIECE(TMP(1),"^")
SET Y="-1^INVALID PRESCRIPTION #"
QUIT
+37 SET DDR=$PIECE(RX0,"^",6)
if DDR
SET DDR=$$GET1^DIQ(50,DDR,.01)_"^"_DDR
+38 SET STA=$SELECT(RXIEN:$PIECE($GET(^PSRX(RXIEN,"STA")),"^")_";"_$$GET1^DIQ(52,RXIEN,100),1:99_";"_$$GET1^DIQ(52.41,PIEN,2))
+39 ;
+40 ;PSD-89
NEW NATURE
SET NATURE=$SELECT(ERXIEN:"ELECTRONICALLY RECEIVED",1:$PIECE($$NATURE^ORUTL3(ORIEN),"^",3))
+41 ;PSD-89
SET Y="1^"_ORIEN_"^"_NATURE_"^"_STA_"^"_$PIECE(TMP(1),"^",2)
+42 SET Y(1)=$PIECE(TMP(4),"^")_"^"_TMP(5)
+43 SET Y(2)=$SELECT($PIECE(TMP(1),"^",3)'="":$PIECE(TMP(1),"^",3,4),DDR'="":DDR,1:"^")_"^"_$PIECE(TMP(1),"^",6)_"^^"_$PIECE(TMP(1),"^",5)_U_$PIECE(TMP(1),U,8)
+44 SET Y(3)=""
MERGE Y(3)=TMP(6)
+45 SET Y(4)=$PIECE(TMP(2),"^",3)_"^"_$PIECE(TMP(2),"^",4)_"^"_$PIECE(TMP(2),"^",1,2)
+46 SET Y(5)=TMP(3)
+47 SET ORI=$SELECT($PIECE(RXOI,"^"):$PIECE(RXOI,"^"),1:$PIECE(PND0,"^",8))
+48 SET ORIE=$SELECT($DATA(^PS(50.7,ORI,0)):$PIECE(^PS(50.7,ORI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^"),1:"")
+49 SET Y(6)=ORIE_"^"_ORI
+50 SET CN=$ORDER(TMP(7,""))
IF CN'=""
SET $PIECE(Y(2),"^")=$PIECE(Y(2),"^")_" "_$TRANSLATE(TMP(7,CN),"^"," ")
+51 SET Y(7)=""
MERGE Y(7)=TMP(7)
IF CN'=""
KILL Y(7,CN)
+52 SET $PIECE(Y,"^",10)=1
+53 ;PATCH PSD*3*83 - Added functionality to add the ECME # to the Y array
+54 IF RXIEN
Begin DoDot:1
+55 SET RFL=$$LSTRFL^PSOBPSU1(RXIEN)
+56 SET ECME=$$ECMENUM^PSOBPSU2(RXIEN,RFL)
+57 SET Y(8)=ECME
End DoDot:1
+58 QUIT
+59 ;
FSIG(PSOFILE,PSOINTR,PSOLENTH) ;Format front door sig
+1 ;PSOFILE is 'P' if in Pending File, 'R' if in Prescription File
+2 ;PSOINTR is internal number for either file
+3 ;PSOLENTH is length of each line of the Sig
+4 ;returned in the FSIG array
+5 KILL FSIG
IF $GET(PSOFILE)=""!('$GET(PSOINTR))!('$GET(PSOLENTH))
GOTO FQUIT
+6 IF PSOFILE'="P"
IF PSOFILE'="R"
GOTO FQUIT
+7 IF PSOFILE="P"
IF '$DATA(^PS(52.41,+PSOINTR,0))
GOTO FQUIT
+8 IF PSOFILE="R"
IF '$DATA(^PSRX(+PSOINTR,0))
GOTO FQUIT
+9 IF PSOFILE="R"
IF '$PIECE($GET(^PSRX(+PSOINTR,"SIG")),"^",2)
GOTO FQUIT
+10 NEW FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
+11 IF PSOFILE="P"
FOR NNN=0:0
SET NNN=$ORDER(^PS(52.41,PSOINTR,"SIG",NNN))
if 'NNN
QUIT
if $GET(^(NNN,0))'=""
SET HSIG(NNN)=^(0)
+12 IF PSOFILE="P"
if '$ORDER(HSIG(0))
GOTO FQUIT
GOTO FSTART
+13 SET FFF=1
FOR NNN=0:0
SET NNN=$ORDER(^PSRX(PSOINTR,"SIG1",NNN))
if 'NNN
QUIT
IF $GET(^(NNN,0))'=""
SET HSIG(FFF)=^(0)
SET FFF=FFF+1
+14 if '$ORDER(HSIG(0))
GOTO FQUIT
FSTART SET (FVAR,FVAR1)=""
SET II=1
+1 FOR FFF=0:0
SET FFF=$ORDER(HSIG(FFF))
if 'FFF
QUIT
SET CNT=0
FOR NNN=1:1:$LENGTH(HSIG(FFF))
IF $EXTRACT(HSIG(FFF),NNN)=" "!($LENGTH(HSIG(FFF))=NNN)
SET CNT=CNT+1
Begin DoDot:1
+2 SET FVAR1=$PIECE(HSIG(FFF)," ",(CNT))
+3 SET FLIM=FVAR
+4 SET FVAR=$SELECT(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
End DoDot:1
IF $LENGTH(FVAR)>PSOLENTH
SET FSIG(II)=FLIM_" "
SET II=II+1
SET FVAR=FVAR1
+5 IF $GET(FVAR)'=""
SET FSIG(II)=FVAR
+6 IF $GET(FSIG(1))=""!($GET(FSIG(1))=" ")
SET FSIG(1)=$GET(FSIG(2))
KILL FSIG(2)
FQUIT QUIT
+1 ;
SIG(RXIEN) ; Directions
+1 NEW SIG,I
SET SIG=""
+2 IF $GET(RXIEN)
Begin DoDot:1
+3 FOR I=1:1
if '$DATA(^PSRX(RXIEN,"SIG1",I))
QUIT
Begin DoDot:2
+4 SET SIG=SIG_$GET(^PSRX(RXIEN,"SIG1",I,0))
End DoDot:2
End DoDot:1
+5 QUIT SIG
