- 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 Feb 18, 2025@23:11:57 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