PSOPKIV1 ;BHAM ISC/MHA - validate PKI cert. ; 05/09/2002 8:15 am
;;7.0;OUTPATIENT PHARMACY;**131,146,223,148,249**;DEC 1997;Build 9
;Ref. to ^ORWOR1 supported by DBIA 3750
CER ;
N P1,P2
I $D(OR0) S P1=$P(OR0,"^"),P2=$P(OR0,"^",2)
E S P1=$P($G(^PSRX(DA,"OR1")),"^",2),P2=$P($G(^(0)),"^",2)
I P1<1 S PKI=-1,VALMSG="Invalid CPRS Pointer - Unable to Process" Q
CT N PKIRT D VERIFY^ORWOR1(.PKIRT,P1,P2)
S PKI=+PKIRT I PKI=1 S VALMSG="Digitally Signed Order",PKIE="Processing "_VALMSG Q
I PKI<2 S VALMSG=$P(PKIRT,"^",2) Q
S PKI1=$S(PKI>89802014&(PKI<89802019)!((PKI>89802020)&(PKI<89802023)):2,1:1)
S PKIE="Digital Signature Failed: "_$P($T(@($E(PKI,7,8))),";;",2)
S:'$G(PSOZVER) VALMSG="Signature Failed: "_$P($T(@($E(PKI,7,8))),";;",2)
S:PKI1=2 PKIE=PKIE_" - Order Auto Discontinued" S:$L(PKIE)>75 PKIE=$E(PKIE,1,75)
Q
L1 ;
S PKID=1,IEN=IEN+1,^TMP($S($G(ST)=1:"PSOAO",1:"PSOPO"),$J,IEN,0)=PKIE Q
ERR(ER) ;
Q:'ER
N ERM S ERM=$P($T(@($E(ER,7,8))),";;",2) I ERM]"" Q "Signature Failed: "_ERM
Q ""
REA ;
D KV^PSOVER1
W ! S DIR("A")="Enter Override Reason ",DIR(0)="F^5:70",DIR("?")="Free text reason must be entered, should be between 5 to 70 characters and must not contain embedded up-arrow, e.g. Spoke with the Provider."
S:$G(PKIR)]"" DIR("B")=PKIR D ^DIR S:'$D(DIRUT) PKIR=Y
I $D(DIRUT) K PKIR I $D(OR0) S:$P(OR0,"^",3)="RNW" PSONEW("QFLG")=1 S:$P(OR0,"^",3)="NW" PSORX("DFLG")=1
D KV^PSOVER1 K Y Q
ACT(DA) ;
Q:'DA
N I,J D AR
S ^PSRX(DA,"A",0)="^52.3DA^"_J_"^"_J,^PSRX(DA,"A",J,0)=%_"^K^"_DUZ_"^0^INVALID PKI CERT. "_PKI
S ^PSRX(DA,"A",J,2,1,0)=PKIR,^PSRX(DA,"A",J,2,0)="^52.34A^1^1"
K PKIR Q
;
AR ;
S (I,J)=0 F S I=$O(^PSRX(DA,"A",I)) Q:'I S J=I
S J=J+1 D NOW^%DTC Q
DCP ;
Q:'$D(^PS(52.41,ORD,0))
K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
S $P(^PS(52.41,ORD,0),"^",3)="DC"
S PKIE=$P(PKIE," - ")_" - "_PKI,$P(^PS(52.41,ORD,4),"^")=PKIE
D EN^PSOHLSN($P(^PS(52.41,ORD,0),"^"),"OD",PKIE,"A")
Q
;
DCV ;
W ! D KV^PSOVER1 K PKIR S DIR(0)="Y",DIR("B")="N",DIR("A",1)="Digitally signed Schedule II Rx cannot be deleted, it can only be D/Ced."
S DIR("A")="Are you sure you want to D/C this Rx: " D ^DIR,KV^PSOVER1
I 'Y S VALMSG="No Action Taken!",VALMBCK="R" Q
S:'$D(INCOM) INCOM="DCed by Pharmacy for PKI" S DIR("B")=INCOM
;
W ! S DIR("A")="Reason for D/Cing",DIR(0)="F^5:75",DIR("?")="Reason must be entered and should be 5 to 75 characters and must not contain embedded uparrow"
D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMSG="No Action Taken!",VALMBCK="R" Q
S PKIR=Y D KV^PSOVER1
DCV0 Q:'$D(^PS(52.4,DA,0))
S $P(^PSRX(DA,"STA"),"^")=12,$P(^PSRX(DA,3),"^",5)=DT
D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA) N I,J D AR
S ^PSRX(DA,"A",J,0)=%_"^C^"_DUZ_"^0^Discontinued during verification"
S J=J+1 D ADR
N PKIX S PKIX=DA D EN^PSOHLSN1(DA,"OD","",PKIR,PSONOOR)
S DA=PKIX S DIK="^PS(52.4," D ^DIK K DIK
Q
;
DCV1 N PKIR,PSONOOR,DA S DA=PSONV,PKIR=$P($G(PKIE),"-")_" - "_PKI,PSONOOR="A" D DCV0
Q
ADR ;
S ^PSRX(DA,"A",0)="^52.3DA^"_J_"^"_J
S ^PSRX(DA,"A",J,0)=%_"^K^"_DUZ_"^0^Digitally signed"
S ^PSRX(DA,"A",J,2,1,0)=$S($G(PKIR)]"":PKIR,1:"Digitally signed order Discontinued"),^PSRX(DA,"A",J,2,0)="^52.34A^1^1"
Q
RV ;
N TY,T,T1,T2,MIG,SG
S (T,T2)=0
F S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T D
.S T1=0,$P(TY(T2)," ",23)=" "
.F S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1 D
..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0)
..F SG=1:1:$L(MIG," ") S:$L(TY(T2)_" "_$P(MIG," ",SG))>80 T2=T2+1,$P(TY(T2)," ",23)=" " S TY(T2)=$G(TY(T2))_" "_$P(MIG," ",SG)
.S T2=T2+4
S T2=T2+2 D CNTRL^VALM10(T2,1,$L(PKIE),IORVON,IORVOFF,0)
Q
;
00 ;;Order Text is blank;;
01 ;;DEA # missing;;
02 ;;Drug Schedule missing;;
03 ;;DEA # not valid;;
04 ;;Valid Certificate not found;;
05 ;;Couldn't load CSP;;
06 ;;Smart card Reader not found;;
07 ;;Certificate with DEA # not found;;
08 ;;Certificate not valid for schedule;;
10 ;;Crypto Error (contact IRM);;
15 ;;Corrupted (Decode failure);;
16 ;;Corrupted (Hash mismatch);;
17 ;;Certificate revoked;;
18 ;;Verification failure;;
19 ;;Before Cert effective date;;
20 ;;Certificate expired;;
21 ;;No Cert with a valid date found;;
22 ;;Signature Check failed (Invalid Signature);;
PSOPKIV1 ;BHAM ISC/MHA - validate PKI cert. ; 05/09/2002 8:15 am
+1 ;;7.0;OUTPATIENT PHARMACY;**131,146,223,148,249**;DEC 1997;Build 9
+2 ;Ref. to ^ORWOR1 supported by DBIA 3750
CER ;
+1 NEW P1,P2
+2 IF $DATA(OR0)
SET P1=$PIECE(OR0,"^")
SET P2=$PIECE(OR0,"^",2)
+3 IF '$TEST
SET P1=$PIECE($GET(^PSRX(DA,"OR1")),"^",2)
SET P2=$PIECE($GET(^(0)),"^",2)
+4 IF P1<1
SET PKI=-1
SET VALMSG="Invalid CPRS Pointer - Unable to Process"
QUIT
CT NEW PKIRT
DO VERIFY^ORWOR1(.PKIRT,P1,P2)
+1 SET PKI=+PKIRT
IF PKI=1
SET VALMSG="Digitally Signed Order"
SET PKIE="Processing "_VALMSG
QUIT
+2 IF PKI<2
SET VALMSG=$PIECE(PKIRT,"^",2)
QUIT
+3 SET PKI1=$SELECT(PKI>89802014&(PKI<89802019)!((PKI>89802020)&(PKI<89802023)):2,1:1)
+4 SET PKIE="Digital Signature Failed: "_$PIECE($TEXT(@($EXTRACT(PKI,7,8))),";;",2)
+5 IF '$GET(PSOZVER)
SET VALMSG="Signature Failed: "_$PIECE($TEXT(@($EXTRACT(PKI,7,8))),";;",2)
+6 IF PKI1=2
SET PKIE=PKIE_" - Order Auto Discontinued"
IF $LENGTH(PKIE)>75
SET PKIE=$EXTRACT(PKIE,1,75)
+7 QUIT
L1 ;
+1 SET PKID=1
SET IEN=IEN+1
SET ^TMP($SELECT($GET(ST)=1:"PSOAO",1:"PSOPO"),$JOB,IEN,0)=PKIE
QUIT
ERR(ER) ;
+1 IF 'ER
QUIT
+2 NEW ERM
SET ERM=$PIECE($TEXT(@($EXTRACT(ER,7,8))),";;",2)
IF ERM]""
QUIT "Signature Failed: "_ERM
+3 QUIT ""
REA ;
+1 DO KV^PSOVER1
+2 WRITE !
SET DIR("A")="Enter Override Reason "
SET DIR(0)="F^5:70"
SET DIR("?")="Free text reason must be entered, should be between 5 to 70 characters and must not contain embedded up-arrow, e.g. Spoke with the Provider."
+3 IF $GET(PKIR)]""
SET DIR("B")=PKIR
DO ^DIR
IF '$DATA(DIRUT)
SET PKIR=Y
+4 IF $DATA(DIRUT)
KILL PKIR
IF $DATA(OR0)
IF $PIECE(OR0,"^",3)="RNW"
SET PSONEW("QFLG")=1
IF $PIECE(OR0,"^",3)="NW"
SET PSORX("DFLG")=1
+5 DO KV^PSOVER1
KILL Y
QUIT
ACT(DA) ;
+1 IF 'DA
QUIT
+2 NEW I,J
DO AR
+3 SET ^PSRX(DA,"A",0)="^52.3DA^"_J_"^"_J
SET ^PSRX(DA,"A",J,0)=%_"^K^"_DUZ_"^0^INVALID PKI CERT. "_PKI
+4 SET ^PSRX(DA,"A",J,2,1,0)=PKIR
SET ^PSRX(DA,"A",J,2,0)="^52.34A^1^1"
+5 KILL PKIR
QUIT
+6 ;
AR ;
+1 SET (I,J)=0
FOR
SET I=$ORDER(^PSRX(DA,"A",I))
IF 'I
QUIT
SET J=I
+2 SET J=J+1
DO NOW^%DTC
QUIT
DCP ;
+1 IF '$DATA(^PS(52.41,ORD,0))
QUIT
+2 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,ORD,0),"^",2),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$PIECE(^PS(52.41,ORD,0),"^",12),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+3 SET $PIECE(^PS(52.41,ORD,0),"^",3)="DC"
+4 SET PKIE=$PIECE(PKIE," - ")_" - "_PKI
SET $PIECE(^PS(52.41,ORD,4),"^")=PKIE
+5 DO EN^PSOHLSN($PIECE(^PS(52.41,ORD,0),"^"),"OD",PKIE,"A")
+6 QUIT
+7 ;
DCV ;
+1 WRITE !
DO KV^PSOVER1
KILL PKIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A",1)="Digitally signed Schedule II Rx cannot be deleted, it can only be D/Ced."
+2 SET DIR("A")="Are you sure you want to D/C this Rx: "
DO ^DIR
DO KV^PSOVER1
+3 IF 'Y
SET VALMSG="No Action Taken!"
SET VALMBCK="R"
QUIT
+4 IF '$DATA(INCOM)
SET INCOM="DCed by Pharmacy for PKI"
SET DIR("B")=INCOM
+5 ;
+6 WRITE !
SET DIR("A")="Reason for D/Cing"
SET DIR(0)="F^5:75"
SET DIR("?")="Reason must be entered and should be 5 to 75 characters and must not contain embedded uparrow"
+7 DO ^DIR
IF $DATA(DIRUT)
DO KV^PSOVER1
SET VALMSG="No Action Taken!"
SET VALMBCK="R"
QUIT
+8 SET PKIR=Y
DO KV^PSOVER1
DCV0 IF '$DATA(^PS(52.4,DA,0))
QUIT
+1 SET $PIECE(^PSRX(DA,"STA"),"^")=12
SET $PIECE(^PSRX(DA,3),"^",5)=DT
+2 DO REVERSE^PSOBPSU1(DA,,"DC",7)
DO CAN^PSOTPCAN(DA)
NEW I,J
DO AR
+3 SET ^PSRX(DA,"A",J,0)=%_"^C^"_DUZ_"^0^Discontinued during verification"
+4 SET J=J+1
DO ADR
+5 NEW PKIX
SET PKIX=DA
DO EN^PSOHLSN1(DA,"OD","",PKIR,PSONOOR)
+6 SET DA=PKIX
SET DIK="^PS(52.4,"
DO ^DIK
KILL DIK
+7 QUIT
+8 ;
DCV1 NEW PKIR,PSONOOR,DA
SET DA=PSONV
SET PKIR=$PIECE($GET(PKIE),"-")_" - "_PKI
SET PSONOOR="A"
DO DCV0
+1 QUIT
ADR ;
+1 SET ^PSRX(DA,"A",0)="^52.3DA^"_J_"^"_J
+2 SET ^PSRX(DA,"A",J,0)=%_"^K^"_DUZ_"^0^Digitally signed"
+3 SET ^PSRX(DA,"A",J,2,1,0)=$SELECT($GET(PKIR)]"":PKIR,1:"Digitally signed order Discontinued")
SET ^PSRX(DA,"A",J,2,0)="^52.34A^1^1"
+4 QUIT
RV ;
+1 NEW TY,T,T1,T2,MIG,SG
+2 SET (T,T2)=0
+3 FOR
SET T=$ORDER(^PS(52.41,ORD,"OBX",T))
IF 'T
QUIT
Begin DoDot:1
+4 SET T1=0
SET $PIECE(TY(T2)," ",23)=" "
+5 FOR
SET T1=$ORDER(^PS(52.41,ORD,"OBX",T,2,T1))
IF 'T1
QUIT
Begin DoDot:2
+6 SET MIG=^PS(52.41,ORD,"OBX",T,2,T1,0)
+7 FOR SG=1:1:$LENGTH(MIG," ")
IF $LENGTH(TY(T2)_" "_$PIECE(MIG," ",SG))>80
SET T2=T2+1
SET $PIECE(TY(T2)," ",23)=" "
SET TY(T2)=$GET(TY(T2))_" "_$PIECE(MIG," ",SG)
End DoDot:2
+8 SET T2=T2+4
End DoDot:1
+9 SET T2=T2+2
DO CNTRL^VALM10(T2,1,$LENGTH(PKIE),IORVON,IORVOFF,0)
+10 QUIT
+11 ;
00 ;;Order Text is blank;;
01 ;;DEA # missing;;
02 ;;Drug Schedule missing;;
03 ;;DEA # not valid;;
04 ;;Valid Certificate not found;;
05 ;;Couldn't load CSP;;
06 ;;Smart card Reader not found;;
07 ;;Certificate with DEA # not found;;
08 ;;Certificate not valid for schedule;;
10 ;;Crypto Error (contact IRM);;
15 ;;Corrupted (Decode failure);;
16 ;;Corrupted (Hash mismatch);;
17 ;;Certificate revoked;;
18 ;;Verification failure;;
19 ;;Before Cert effective date;;
20 ;;Certificate expired;;
21 ;;No Cert with a valid date found;;
22 ;;Signature Check failed (Invalid Signature);;
