- 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
