PSDDSOR1 ;BHM/MHA/PWC - Digitally signed CS Orders Report; 08/30/02
;;3.0; CONTROLLED SUBSTANCES ;**40,67**;13 Feb 97;Build 8
;Ref. to ^PSRX( supported by DBIA 1977
;Ref. to ^PS(52.41, supported by DBIA 3848
; PSD*3*67 added checks for pending file to only include information
; about patient in pending file ^PS(52.41
;
Q
PRT I ($Y+13)>IOSL D:AC HD^PSDDSOR D:'AC HD^PSDDSOR2 Q:$D(DIRUT)
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 Federal Schedule: "_$P(Y2,"^",5)
W !?2,"Provider: "_$E($P(Y4,"^")_P1,1,30),?50,"DEA #: "_$S($P(Y4,"^",3)]"":$P(Y4,"^",3),$P(Y4,"^",2):$$DEA^XUSER(,$P(Y4,"^",2)),1:"")
S PL=$P(Y5,"^"),PL1="" F I=2:1:6 S J=$P(Y5,"^",I) D:J]""
.I $L(J)+$L(PL)<60 S PL=PL_", "_J
.E S PL1=PL1_$S(PL1]"":", ",1:"")_J
W !?2,"Provider Address: "_PL W:PL1]"" !?23,PL1
W !?2,"CPRS Order #: "_$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)
W !?2,"Patient Name: "_$E($P(Y1,"^")_P1,1,30),?50,"PATIENT ID: "
S DFN=$S(AC=4:$P($G(^PS(52.41,S5,0)),"^",2),1:$P(^PSRX(S5,0),"^",2)) D PID^VADPT W $E($P(Y1,"^"))_VA("BID")
S PL=$P(Y1,"^",2),PL1="" F I=3:1:7 S J=$P(Y1,"^",I) D:J]""
.I $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(AC=4:"",$D(^PSRX(S5,0)):$P(^PSRX(S5,0),"^"),1:"")
W ?50,"Qty: "_$S(AC=4:$P(^PS(52.41,S5,0),"^",10),1:$P(Y2,"^",3))
W !?2,"SIG: "
S PL=0 I AC'=4,$D(^PSRX(S5,"SIG1")) D G P1
.F S PL=$O(^PSRX(S5,"SIG1",PL)) Q:'PL W:PL>1 ! W ?7,^PSRX(S5,"SIG1",PL,0)
I AC=4,$D(^PS(52.41,S5,"SIG")) D G P1
.F S PL=$O(^PS(52.41,S5,"SIG",PL)) Q:'PL W:PL>1 ! W ?7,^PS(52.41,S5,"SIG",PL,0)
W ?7,$P(Y3,"^")
P1 S RX2=$S(AC=4:"",$D(^PSRX(S5,2)):^PSRX(S5,2),1:"")
W !?2,"Date Filled: " S Y=$P(RX2,"^",2) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
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?: "
N FL0 S FL0=$S(AC=4:"No",1:"Yes"),Y=$P(RX2,"^",2)
I AC'=4,$D(^PSRX(S5,"A")) N FL S FL=0 F S FL=$O(^PSRX(S5,"A",FL)) Q:'FL!(FL0="No") I $P(^PSRX(S5,"A",FL,0),"^",2)="K" S FL0="No",Y=$P($P(^(0),"^"),".")
W FL0
W !?2,"Date Signature Validation Attempted by Pharmacy: "
I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
W !?2,"CPRS Nature of Order: "_$P(Y0,"^",3),?50,"CPRS Status: "_$P($P(Y0,"^",4),";",2)
S PL=$S($P(Y0,"^",7)]"":$P(Y0,"^",7),$P(Y0,"^"):"Digitally Signed",1:"")
W !?2,"Signature Status: "_$E(PL,1,60) W:$L(PL)>60 !,?20,$E(PL,61,200) W !
Q
PSDDSOR1 ;BHM/MHA/PWC - Digitally signed CS Orders Report; 08/30/02
+1 ;;3.0; CONTROLLED SUBSTANCES ;**40,67**;13 Feb 97;Build 8
+2 ;Ref. to ^PSRX( supported by DBIA 1977
+3 ;Ref. to ^PS(52.41, supported by DBIA 3848
+4 ; PSD*3*67 added checks for pending file to only include information
+5 ; about patient in pending file ^PS(52.41
+6 ;
+7 QUIT
PRT IF ($Y+13)>IOSL
IF AC
DO HD^PSDDSOR
IF 'AC
DO HD^PSDDSOR2
IF $DATA(DIRUT)
QUIT
+1 SET I=0
SET PL=""
+2 IF $PIECE($GET(Y2),"^")]""
SET PL=$EXTRACT($PIECE(Y2,"^"),1,30)
+3 IF '$TEST
SET PL=$EXTRACT($PIECE($GET(Y6),"^"),1,30)
SET I=1
+4 WRITE !?1," DRUG"_$SELECT($GET(I):" (OI)",1:"")_": "_PL,?50,"CS Federal Schedule: "_$PIECE(Y2,"^",5)
+5 WRITE !?2,"Provider: "_$EXTRACT($PIECE(Y4,"^")_P1,1,30),?50,"DEA #: "_$SELECT($PIECE(Y4,"^",3)]"":$PIECE(Y4,"^",3),$PIECE(Y4,"^",2):$$DEA^XUSER(,$PIECE(Y4,"^",2)),1:"")
+6 SET PL=$PIECE(Y5,"^")
SET PL1=""
FOR I=2:1:6
SET J=$PIECE(Y5,"^",I)
IF J]""
Begin DoDot:1
+7 IF $LENGTH(J)+$LENGTH(PL)<60
SET PL=PL_", "_J
+8 IF '$TEST
SET PL1=PL1_$SELECT(PL1]"":", ",1:"")_J
End DoDot:1
+9 WRITE !?2,"Provider Address: "_PL
IF PL1]""
WRITE !?23,PL1
+10 WRITE !?2,"CPRS Order #: "_$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)
+11 WRITE !?2,"Patient Name: "_$EXTRACT($PIECE(Y1,"^")_P1,1,30),?50,"PATIENT ID: "
+12 SET DFN=$SELECT(AC=4:$PIECE($GET(^PS(52.41,S5,0)),"^",2),1:$PIECE(^PSRX(S5,0),"^",2))
DO PID^VADPT
WRITE $EXTRACT($PIECE(Y1,"^"))_VA("BID")
+13 SET PL=$PIECE(Y1,"^",2)
SET PL1=""
FOR I=3:1:7
SET J=$PIECE(Y1,"^",I)
IF J]""
Begin DoDot:1
+14 IF $LENGTH(J)+$LENGTH(PL)<60
SET PL=PL_", "_J
+15 IF '$TEST
SET PL1=PL1_$SELECT(PL1]"":", ",1:"")_J
End DoDot:1
+16 WRITE !?2,"Patient Address: "_PL
IF PL1]""
WRITE !?19,PL1
+17 WRITE !?2,"Rx #: "_$SELECT(AC=4:"",$DATA(^PSRX(S5,0)):$PIECE(^PSRX(S5,0),"^"),1:"")
+18 WRITE ?50,"Qty: "_$SELECT(AC=4:$PIECE(^PS(52.41,S5,0),"^",10),1:$PIECE(Y2,"^",3))
+19 WRITE !?2,"SIG: "
+20 SET PL=0
IF AC'=4
IF $DATA(^PSRX(S5,"SIG1"))
Begin DoDot:1
+21 FOR
SET PL=$ORDER(^PSRX(S5,"SIG1",PL))
IF 'PL
QUIT
IF PL>1
WRITE !
WRITE ?7,^PSRX(S5,"SIG1",PL,0)
End DoDot:1
GOTO P1
+22 IF AC=4
IF $DATA(^PS(52.41,S5,"SIG"))
Begin DoDot:1
+23 FOR
SET PL=$ORDER(^PS(52.41,S5,"SIG",PL))
IF 'PL
QUIT
IF PL>1
WRITE !
WRITE ?7,^PS(52.41,S5,"SIG",PL,0)
End DoDot:1
GOTO P1
+24 WRITE ?7,$PIECE(Y3,"^")
P1 SET RX2=$SELECT(AC=4:"",$DATA(^PSRX(S5,2)):^PSRX(S5,2),1:"")
+1 WRITE !?2,"Date Filled: "
SET Y=$PIECE(RX2,"^",2)
IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+2 WRITE ?50,"Date Released: "
SET Y=$PIECE(RX2,"^",13)
IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+3 WRITE !?2,"Releasing Pharmacist: "_$SELECT($PIECE(RX2,"^",3):$PIECE(^VA(200,$PIECE(RX2,"^",3),0),"^"),1:"")
+4 WRITE ?50,"Valid PKI Certificate?: "
+5 NEW FL0
SET FL0=$SELECT(AC=4:"No",1:"Yes")
SET Y=$PIECE(RX2,"^",2)
+6 IF AC'=4
IF $DATA(^PSRX(S5,"A"))
NEW FL
SET FL=0
FOR
SET FL=$ORDER(^PSRX(S5,"A",FL))
IF 'FL!(FL0="No")
QUIT
IF $PIECE(^PSRX(S5,"A",FL,0),"^",2)="K"
SET FL0="No"
SET Y=$PIECE($PIECE(^(0),"^"),".")
+7 WRITE FL0
+8 WRITE !?2,"Date Signature Validation Attempted by Pharmacy: "
+9 IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+10 WRITE !?2,"CPRS Nature of Order: "_$PIECE(Y0,"^",3),?50,"CPRS Status: "_$PIECE($PIECE(Y0,"^",4),";",2)
+11 SET PL=$SELECT($PIECE(Y0,"^",7)]"":$PIECE(Y0,"^",7),$PIECE(Y0,"^"):"Digitally Signed",1:"")
+12 WRITE !?2,"Signature Status: "_$EXTRACT(PL,1,60)
IF $LENGTH(PL)>60
WRITE !,?20,$EXTRACT(PL,61,200)
WRITE !
+13 QUIT
