PSOPKIV1 ;BHAM ISC/MHA - validate PKI cert. ; 05/09/2002 8:15 am
;;7.0;OUTPATIENT PHARMACY;**131,146,223,148,249,391,426,462,572,630,545**;DEC 1997;Build 270
;Ref. to ^ORDEA is supported by DBIA 5709
;Ref. to ^ORB supported by DBIA 1362
;Ref. to ^XUSSPKI supported by DBIA 3539
;*545 - Replaced 'Certificate expired' with 'Rx processed: PIV Card Cert Expired - NO ACTION REQ'
;*545 - Replaced 'Certificate revoked' with 'Rx NOT processed: PIV Card Certificate Revoked'
CER ;
;N PKIRT
N PKIRT,MSG ;572
D VERIFY(.PKIRT,ORD)
S PKI=+PKIRT I PKI=1!(PKI=89802020) D Q
. ;S PKI1=1,VALMSG="Digitally Signed Order",PKIE="Processing "_VALMSG
. S PKI1=1,MSG="Digitally Signed Order",PKIE="Processing "_MSG ;572
. I PKI=89802020 S PKIE=PKIE_": "_$P($T(@($E(PKI,7,8))),";;",2)
I PKI<2 S VALMSG=$P(PKIRT,"^",2) Q
S PKI1=$S(PKI>89802014&(PKI<89802020)!((PKI>89802020)&(PKI<89802031)):2,1:1)
S PKIE="Digital Signature Failed: "_$P($T(@($E(PKI,7,8))),";;",2)
I PKI1=2 D
.S VALMSG="Signature Failed: "_$P($T(@($E(PKI,7,8))),";;",2)
.S PKIE=PKIE_" - Order Auto Discontinued"
S:$L(PKIE)>80 PKIE=$E(PKIE,1,80)
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)) N PKIOR,PKIORM
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
S PKIOR=$E(PKI,7,8)
S PKIORM=$S(PKIOR=16:"16:Order has been modified. Resubmit or contact Pharmacy.",PKIOR=17:"17:PIV Certificate revoked. Resubmit or contact Pharmacy.",1:PKIE)
D EN^PSOHLSN($P(^PS(52.41,ORD,0),"^"),"OC",PKIORM,"A")
D ^PSOPKIV2
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
Q
;
VERIFY(RET,PSIEN) ;Verify PKI Data
;PSIEN = IEN of file 52.41 ;ORIFN;ACTION - NOTE: if no ACTION then 1 (new order) is assumed
;Returned values: "1" if digital signature verifies
; "-1^error message" if DS fails during initial parameter checking
; "898020xx^message" if DS fails during verification
;
N PSO0,DFN,PSIG,I,INFO,INF1,DEA,INST,HASH,DATE
I $G(PSIEN)="" S RET="-1^Invalid order number" Q
K ^TMP("PSOPKIDATA",$J)
S PSO0=$G(^PS(52.41,PSIEN,0))
S ^TMP("PSOPKIDATA",$J,"ISSUANCE DATE",1)=$$FMTE^XLFDT($P($P(PSO0,"^",6),"."))
;patient inf
S DFN=$P(PSO0,"^",2) D DEM^VADPT,ADD^VADPT
S ^TMP("PSOPKIDATA",$J,"PATIENT NAME",2)=VADM(1)
S ^TMP("PSOPKIDATA",$J,"PATIENT ADDRESS",3)=VAPA(1)_"^"_VAPA(2)_"^"_VAPA(3)_"^"_VAPA(4)_"^"_$P(VAPA(5),"^")_"^"_$P(VAPA(5),"^",2)_"^"_VAPA(6)_"^"_VAPA(7)
S ^TMP("PSOPKIDATA",$J,"QUANTITY",5)=$P(PSO0,"^",10)
K ^TMP($J,"ORDEA")
D ARCHIVE^ORDEA(+PSO0)
;POS DOSE
N J,INF0,INF1,PSIG
S J=0 F S J=$O(^PS(52.41,PSIEN,1,J)) Q:'J D
.S INF0=$G(^PS(52.41,PSIEN,9,J,0)),INF1=$G(^PS(52.41,PSIEN,1,J,1))
.S PSIG=INF0_"|"_$P(INF1,"^")_"|"_$S($E($P(INF1,"^",2))="L":"M"_$E($P(INF1,"^",2),2,99),1:$P(INF1,"^",2))_"|"_$P(INF1,"^",6)_"|"_$P(INF1,"^",8)
.S ^TMP("PSOPKIDATA",$J,"DIRECTIONS",6,J)=PSIG
I +$P(PSO0,"^",9),+$P(PSO0,"^",25) S ^TMP("PSOPKIDATA",$J,"DRUG NAME",4)=$$GET1^DIQ(50,$P(PSO0,"^",9),.01)
S DEA=$P($G(^TMP($J,"ORDEA",+PSO0,2)),"^")
S ^TMP("PSOPKIDATA",$J,"PROVIDER NAME",8)=$$GET1^DIQ(200,$P(PSO0,"^",5),.01)
I $D(^TMP($J,"ORDEA",+PSO0,3)) S ^TMP("PSOPKIDATA",$J,"PROVIDER ADDRESS",9)=$P(^(3),"^",2,6)
E D INSTAD
K ^TMP($J,"ORDEA")
D KVA^VADPT
S ^TMP("PSOPKIDATA",$J,"DEA NUMBER",10)=DEA
S ^TMP("PSOPKIDATA",$J,"ORDER NUMBER",11)=$P(PSO0,"^")
S HASH=$$HASHRTN^ORDEA($P(PSO0,"^"))
I '$L(HASH) S RET="-1^Order has no PKI Hash" G VQT
S DATE=$$FMTE^XLFDT($P($P(PSO0,"^",6),"."))
I '$L(DATE) S RET="-1^No date associated with order" G VQT
I +$P($P(^OR(100,+PSO0,8,$O(^OR(100,+PSO0,8,999),-1),0),"^",6),".") S ^TMP("PSOPKIDATA",$J,"ISSUANCE DATE",1)=$$FMTE^XLFDT($P($P(^OR(100,+PSO0,8,$O(^OR(100,+PSO0,8,999),-1),0),"^",6),".")) ;PSO*7*462
S RET=$$VERIFY^XUSSPKI(HASH,$NA(^TMP("PSOPKIDATA",$J)))
I RET="OK"!(RET["No error found for this certificate or chain") S RET=1 G VQT
N ECD S ECD=898020
I RET[ECD S RET=$P(RET,"^",2) G VQT
I RET["not time-valid" S RET=ECD_"20" G VQT
I RET["has been revoked" S RET=ECD_"17" G VQT
I RET["does not have a valid signature" S RET=ECD_"22" G VQT
I RET["not properly time-nested" S RET=ECD_"23" G VQT
I RET["not valid in its proposed usage" S RET=ECD_"24" G VQT
I RET["based on an untrusted root" S RET=ECD_"25" G VQT
I RET["certificates in the certificate chain is unknown" S RET=ECD_"26" G VQT
I RET["authority that the original certificate had certified" S RET=ECD_"27" G VQT
I RET["certificate chain is not complete" S RET=ECD_"28" G VQT
I RET["this chain did not have a valid signature" S RET=ECD_"29" G VQT
I RET["not valid for this usage" S RET=ECD_"30" G VQT
VQT ;
K ^TMP("PSOPKIDATA",$J)
Q
;
INSTAD ;
S INST=$P($G(^PS(52.41,PSIEN,"INI")),"^")
D GETS^DIQ(4,INST,".01;1.01;1.02;1.03;1.04;.02","E","VADR")
S VADD(1)=$G(VADR(4,INST_",",.01,"E")),VADD(2)=$G(VADR(4,INST_",",1.01,"E")),VADD(3)=$G(VADR(4,INST_",",1.02,"E"))
S VADD(4)=$G(VADR(4,INST_",",1.03,"E")),VADD(5)=$G(VADR(4,INST_",",.02,"E")),VADD(6)=$G(VADR(4,INST_",",1.04,"E"))
S ^TMP("PSOPKIDATA",$J,"PROVIDER ADDRESS",9)=VADD(1)_"^"_VADD(2)_"^"_VADD(3)_"^"_VADD(4)_"^"_VADD(5)_"^"_VADD(6)
Q
;
HSHCHK(ARET,PNP) ;Compares digitally signed archived data in file #101.52 against data in OP pending file #52.41
;PSO*7*391/JAM
;Input - PNP - Pending file IEN
;
;Output - returns 1 if the archived data matches the pending file
; 0 if initial parameter checking fails
; -1 if comparison fails; and return array with failed items
;
N DFN,PND0,DRGNM,DEA,DETOX,DFN,J,I,INST,NAM,SIGFL,DOSE,DOSEP,DOSEX,DFRM,TMP,VADD,VADR,INF0,INF1,ASIG,PSIG,ORP,ND
I $G(PNP)="" S ARET=0 Q ARET
S PND0=$G(^PS(52.41,PNP,0)) I PND0="" S ARET=0 Q ARET
S ORP=$P(PND0,"^") I ORP="" S ARET=0 Q ARET
;get archived data from CPRS
K ^TMP($J,"ORDEA")
D ARCHIVE^ORDEA(ORP)
I '$D(^TMP($J,"ORDEA")) S ARET=0 Q ARET
F I=1:1:5 S TMP(I)=$G(^TMP($J,"ORDEA",ORP,I))
I $P($P(PND0,"^",6),".")'=$P(TMP(1),"^",2) S ARET=-1,ARET("ISSUANCE DATE")=$P(TMP(1),"^",2)_"^"_$P($P(PND0,"^",6),".")
S DRGNM=$$GET1^DIQ(50,$P(PND0,"^",9),.01)
I DRGNM'=$P(TMP(1),"^",3) S ARET=-1,ARET("DRUG NAME")=$P(TMP(1),"^",3)_"^"_DRGNM
I $P(PND0,"^",10)'=$P(TMP(1),"^",6) S ARET=-1,ARET("QTY PRESCRIBED")=$P(TMP(1),"^",6)_"^"_$P(PND0,"^",10)
;provider info
S INST=$P($G(^PS(52.41,PNP,"INI")),"^")
;*545
S DEA=$$RXDEA^PSOUTIL(,ORP)
I DEA'=$P(TMP(2),"^") S ARET=-1,ARET("DEA #")=$P(TMP(2),"^")_"^"_DEA
S NAM=$$GET1^DIQ(200,$P(PND0,"^",5),.01) I NAM'=$P(TMP(2),"^",3) S ARET=-1,ARET("PROVIDER NAME")=$P(TMP(2),"^",3)_"^"_NAM
;patient inf
S DFN=$P(PND0,"^",2) D DEM^VADPT,ADD^VADPT
I VADM(1)'=$P(TMP(4),"^") S ARET=-1,ARET("PATIENT NAME")=$P(TMP(4),"^")_"^"_VADM(1)
I VAPA(1)'=$P(TMP(5),"^") S ARET=-1,ARET("PATIENT ADDRESS #1")=$P(TMP(5),"^")_"^"_VAPA(1)
I VAPA(2)'=$P(TMP(5),"^",2) S ARET=-1,ARET("PATIENT ADDRESS #2")=$P(TMP(5),"^",2)_"^"_VAPA(2)
I VAPA(3)'=$P(TMP(5),"^",3) S ARET=-1,ARET("PATIENT ADDRESS #3")=$P(TMP(5),"^",3)_"^"_VAPA(3)
I VAPA(4)'=$P(TMP(5),"^",4) S ARET=-1,ARET("PATIENT CITY")=$P(TMP(5),"^",4)_"^"_VAPA(4)
I $P(VAPA(5),"^",2)'=$P(TMP(5),"^",5) S ARET=-1,ARET("PATIENT STATE")=$P(TMP(5),"^",5)_"^"_$P(VAPA(5),"^",2)
I VAPA(6)'=$P(TMP(5),"^",6) S ARET=-1,ARET("PATIENT ZIP+4")=$P(TMP(5),"^",6)_"^"_VAPA(6)
;sig
M ASIG=^TMP($J,"ORDEA",ORP,6)
S I=0 F S I=$O(^PS(52.41,PNP,1,I)) Q:'I D
.S INF0=$G(^PS(52.41,PNP,9,I,0)),INF1=$G(^PS(52.41,PNP,1,I,1))
.S PSIG(I)=INF0_"|"_$P(INF1,"^")_"|"_$P(INF1,"^",2)_"|"_$P(INF1,"^",6)_"|"_$P(INF1,"^",8)
S I=0 F S I=$O(ASIG(I)) Q:'I I ASIG(I)'=$G(PSIG(I)) S ND="SIG #"_I,ARET=-1 S ARET(ND)=ASIG(I)_"^"_$G(PSIG(I))
D KVA^VADPT
K ^TMP($J,"ORDEA")
Q $S($G(ARET):ARET,1:1)
;
ALERT ;
; ORN=76 - Notification ID (ifn from OE/RR Notifications file #100.9)
; ORBDFN=Patient DFN from Patient file #2
; ORNUM=Order ifn from Order file #100
; ORBADUZ=Provider DUZ - Array of notification recipients requested by the calling package.
; ORBPMSG=Message text
; ORBPDATA=This is an identifier of the package entry which the notification is based on.
; For radiology: Rad/Nuc Med exam/case ifn's(format: exam_ifn;case_ifn)
; For consults: the IEN of the consult in file 123
N PSOX S PSOX=1
S PSOX(+$P(OR0,"^",5))=""
D EN^ORB3(76,PSODFN,$P(OR0,"^"),.PSOX,"Rx processed: PIV Card Cert Expired - NO ACTION REQ","") ;PSO*7*630
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 ;;Rx NOT processed: PIV Card Certificate Revoked;;
18 ;;Verification failure;;
19 ;;Before Cert effective date;;
20 ;;Rx processed: PIV Card Cert Expired - NO ACTION REQ;;
21 ;;No Cert with a valid date found;;
22 ;;Signature Check failed (Invalid Signature);;
23 ;;CERT_IS_NOT_TIME_NESTED;;
24 ;;CERT_IS_NOT_VALID_FOR_USAGE;;
25 ;;CERT_IS_UNTRUSTED_ROOT;;
26 ;;CERT_REVOCATION_STATUS_UNKNOWN;;
27 ;;CERT_IS_CYCLIC;;
28 ;;CERT_IS_PARTIAL_CHAIN;;
29 ;;CERT_CTL_IS_NOT_SIGNATURE_VALID;;
30 ;;CERT_CTL_IS_NOT_VALID_FOR_USAGE;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPKIV1 12023 printed Mar 13, 2025@21:37:36 Page 2
PSOPKIV1 ;BHAM ISC/MHA - validate PKI cert. ; 05/09/2002 8:15 am
+1 ;;7.0;OUTPATIENT PHARMACY;**131,146,223,148,249,391,426,462,572,630,545**;DEC 1997;Build 270
+2 ;Ref. to ^ORDEA is supported by DBIA 5709
+3 ;Ref. to ^ORB supported by DBIA 1362
+4 ;Ref. to ^XUSSPKI supported by DBIA 3539
+5 ;*545 - Replaced 'Certificate expired' with 'Rx processed: PIV Card Cert Expired - NO ACTION REQ'
+6 ;*545 - Replaced 'Certificate revoked' with 'Rx NOT processed: PIV Card Certificate Revoked'
CER ;
+1 ;N PKIRT
+2 ;572
NEW PKIRT,MSG
+3 DO VERIFY(.PKIRT,ORD)
+4 SET PKI=+PKIRT
IF PKI=1!(PKI=89802020)
Begin DoDot:1
+5 ;S PKI1=1,VALMSG="Digitally Signed Order",PKIE="Processing "_VALMSG
+6 ;572
SET PKI1=1
SET MSG="Digitally Signed Order"
SET PKIE="Processing "_MSG
+7 IF PKI=89802020
SET PKIE=PKIE_": "_$PIECE($TEXT(@($EXTRACT(PKI,7,8))),";;",2)
End DoDot:1
QUIT
+8 IF PKI<2
SET VALMSG=$PIECE(PKIRT,"^",2)
QUIT
+9 SET PKI1=$SELECT(PKI>89802014&(PKI<89802020)!((PKI>89802020)&(PKI<89802031)):2,1:1)
+10 SET PKIE="Digital Signature Failed: "_$PIECE($TEXT(@($EXTRACT(PKI,7,8))),";;",2)
+11 IF PKI1=2
Begin DoDot:1
+12 SET VALMSG="Signature Failed: "_$PIECE($TEXT(@($EXTRACT(PKI,7,8))),";;",2)
+13 SET PKIE=PKIE_" - Order Auto Discontinued"
End DoDot:1
+14 if $LENGTH(PKIE)>80
SET PKIE=$EXTRACT(PKIE,1,80)
+15 QUIT
L1 ;
+1 SET PKID=1
SET IEN=IEN+1
SET ^TMP($SELECT($GET(ST)=1:"PSOAO",1:"PSOPO"),$JOB,IEN,0)=PKIE
+2 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
NEW PKIOR,PKIORM
+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 SET PKIOR=$EXTRACT(PKI,7,8)
+6 SET PKIORM=$SELECT(PKIOR=16:"16:Order has been modified. Resubmit or contact Pharmacy.",PKIOR=17:"17:PIV Certificate revoked. Resubmit or contact Pharmacy.",1:PKIE)
+7 DO EN^PSOHLSN($PIECE(^PS(52.41,ORD,0),"^"),"OC",PKIORM,"A")
+8 DO ^PSOPKIV2
+9 QUIT
+10 ;
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 QUIT
+10 ;
VERIFY(RET,PSIEN) ;Verify PKI Data
+1 ;PSIEN = IEN of file 52.41 ;ORIFN;ACTION - NOTE: if no ACTION then 1 (new order) is assumed
+2 ;Returned values: "1" if digital signature verifies
+3 ; "-1^error message" if DS fails during initial parameter checking
+4 ; "898020xx^message" if DS fails during verification
+5 ;
+6 NEW PSO0,DFN,PSIG,I,INFO,INF1,DEA,INST,HASH,DATE
+7 IF $GET(PSIEN)=""
SET RET="-1^Invalid order number"
QUIT
+8 KILL ^TMP("PSOPKIDATA",$JOB)
+9 SET PSO0=$GET(^PS(52.41,PSIEN,0))
+10 SET ^TMP("PSOPKIDATA",$JOB,"ISSUANCE DATE",1)=$$FMTE^XLFDT($PIECE($PIECE(PSO0,"^",6),"."))
+11 ;patient inf
+12 SET DFN=$PIECE(PSO0,"^",2)
DO DEM^VADPT
DO ADD^VADPT
+13 SET ^TMP("PSOPKIDATA",$JOB,"PATIENT NAME",2)=VADM(1)
+14 SET ^TMP("PSOPKIDATA",$JOB,"PATIENT ADDRESS",3)=VAPA(1)_"^"_VAPA(2)_"^"_VAPA(3)_"^"_VAPA(4)_"^"_$PIECE(VAPA(5),"^")_"^"_$PIECE(VAPA(5),"^",2)_"^"_VAPA(6)_"^"_VAPA(7)
+15 SET ^TMP("PSOPKIDATA",$JOB,"QUANTITY",5)=$PIECE(PSO0,"^",10)
+16 KILL ^TMP($JOB,"ORDEA")
+17 DO ARCHIVE^ORDEA(+PSO0)
+18 ;POS DOSE
+19 NEW J,INF0,INF1,PSIG
+20 SET J=0
FOR
SET J=$ORDER(^PS(52.41,PSIEN,1,J))
if 'J
QUIT
Begin DoDot:1
+21 SET INF0=$GET(^PS(52.41,PSIEN,9,J,0))
SET INF1=$GET(^PS(52.41,PSIEN,1,J,1))
+22 SET PSIG=INF0_"|"_$PIECE(INF1,"^")_"|"_$SELECT($EXTRACT($PIECE(INF1,"^",2))="L":"M"_$EXTRACT($PIECE(INF1,"^",2),2,99),1:$PIECE(INF1,"^",2))_"|"_$PIECE(INF1,"^",6)_"|"_$PIECE(INF1,"^",8)
+23 SET ^TMP("PSOPKIDATA",$JOB,"DIRECTIONS",6,J)=PSIG
End DoDot:1
+24 IF +$PIECE(PSO0,"^",9)
IF +$PIECE(PSO0,"^",25)
SET ^TMP("PSOPKIDATA",$JOB,"DRUG NAME",4)=$$GET1^DIQ(50,$PIECE(PSO0,"^",9),.01)
+25 SET DEA=$PIECE($GET(^TMP($JOB,"ORDEA",+PSO0,2)),"^")
+26 SET ^TMP("PSOPKIDATA",$JOB,"PROVIDER NAME",8)=$$GET1^DIQ(200,$PIECE(PSO0,"^",5),.01)
+27 IF $DATA(^TMP($JOB,"ORDEA",+PSO0,3))
SET ^TMP("PSOPKIDATA",$JOB,"PROVIDER ADDRESS",9)=$PIECE(^(3),"^",2,6)
+28 IF '$TEST
DO INSTAD
+29 KILL ^TMP($JOB,"ORDEA")
+30 DO KVA^VADPT
+31 SET ^TMP("PSOPKIDATA",$JOB,"DEA NUMBER",10)=DEA
+32 SET ^TMP("PSOPKIDATA",$JOB,"ORDER NUMBER",11)=$PIECE(PSO0,"^")
+33 SET HASH=$$HASHRTN^ORDEA($PIECE(PSO0,"^"))
+34 IF '$LENGTH(HASH)
SET RET="-1^Order has no PKI Hash"
GOTO VQT
+35 SET DATE=$$FMTE^XLFDT($PIECE($PIECE(PSO0,"^",6),"."))
+36 IF '$LENGTH(DATE)
SET RET="-1^No date associated with order"
GOTO VQT
+37 ;PSO*7*462
IF +$PIECE($PIECE(^OR(100,+PSO0,8,$ORDER(^OR(100,+PSO0,8,999),-1),0),"^",6),".")
SET ^TMP("PSOPKIDATA",$JOB,"ISSUANCE DATE",1)=$$FMTE^XLFDT($PIECE($PIECE(^OR(100,+PSO0,8,$ORDER(^OR(100,+PSO0,8,999),-1),0),"^",6),"."))
+38 SET RET=$$VERIFY^XUSSPKI(HASH,$NAME(^TMP("PSOPKIDATA",$JOB)))
+39 IF RET="OK"!(RET["No error found for this certificate or chain")
SET RET=1
GOTO VQT
+40 NEW ECD
SET ECD=898020
+41 IF RET[ECD
SET RET=$PIECE(RET,"^",2)
GOTO VQT
+42 IF RET["not time-valid"
SET RET=ECD_"20"
GOTO VQT
+43 IF RET["has been revoked"
SET RET=ECD_"17"
GOTO VQT
+44 IF RET["does not have a valid signature"
SET RET=ECD_"22"
GOTO VQT
+45 IF RET["not properly time-nested"
SET RET=ECD_"23"
GOTO VQT
+46 IF RET["not valid in its proposed usage"
SET RET=ECD_"24"
GOTO VQT
+47 IF RET["based on an untrusted root"
SET RET=ECD_"25"
GOTO VQT
+48 IF RET["certificates in the certificate chain is unknown"
SET RET=ECD_"26"
GOTO VQT
+49 IF RET["authority that the original certificate had certified"
SET RET=ECD_"27"
GOTO VQT
+50 IF RET["certificate chain is not complete"
SET RET=ECD_"28"
GOTO VQT
+51 IF RET["this chain did not have a valid signature"
SET RET=ECD_"29"
GOTO VQT
+52 IF RET["not valid for this usage"
SET RET=ECD_"30"
GOTO VQT
VQT ;
+1 KILL ^TMP("PSOPKIDATA",$JOB)
+2 QUIT
+3 ;
INSTAD ;
+1 SET INST=$PIECE($GET(^PS(52.41,PSIEN,"INI")),"^")
+2 DO GETS^DIQ(4,INST,".01;1.01;1.02;1.03;1.04;.02","E","VADR")
+3 SET VADD(1)=$GET(VADR(4,INST_",",.01,"E"))
SET VADD(2)=$GET(VADR(4,INST_",",1.01,"E"))
SET VADD(3)=$GET(VADR(4,INST_",",1.02,"E"))
+4 SET VADD(4)=$GET(VADR(4,INST_",",1.03,"E"))
SET VADD(5)=$GET(VADR(4,INST_",",.02,"E"))
SET VADD(6)=$GET(VADR(4,INST_",",1.04,"E"))
+5 SET ^TMP("PSOPKIDATA",$JOB,"PROVIDER ADDRESS",9)=VADD(1)_"^"_VADD(2)_"^"_VADD(3)_"^"_VADD(4)_"^"_VADD(5)_"^"_VADD(6)
+6 QUIT
+7 ;
HSHCHK(ARET,PNP) ;Compares digitally signed archived data in file #101.52 against data in OP pending file #52.41
+1 ;PSO*7*391/JAM
+2 ;Input - PNP - Pending file IEN
+3 ;
+4 ;Output - returns 1 if the archived data matches the pending file
+5 ; 0 if initial parameter checking fails
+6 ; -1 if comparison fails; and return array with failed items
+7 ;
+8 NEW DFN,PND0,DRGNM,DEA,DETOX,DFN,J,I,INST,NAM,SIGFL,DOSE,DOSEP,DOSEX,DFRM,TMP,VADD,VADR,INF0,INF1,ASIG,PSIG,ORP,ND
+9 IF $GET(PNP)=""
SET ARET=0
QUIT ARET
+10 SET PND0=$GET(^PS(52.41,PNP,0))
IF PND0=""
SET ARET=0
QUIT ARET
+11 SET ORP=$PIECE(PND0,"^")
IF ORP=""
SET ARET=0
QUIT ARET
+12 ;get archived data from CPRS
+13 KILL ^TMP($JOB,"ORDEA")
+14 DO ARCHIVE^ORDEA(ORP)
+15 IF '$DATA(^TMP($JOB,"ORDEA"))
SET ARET=0
QUIT ARET
+16 FOR I=1:1:5
SET TMP(I)=$GET(^TMP($JOB,"ORDEA",ORP,I))
+17 IF $PIECE($PIECE(PND0,"^",6),".")'=$PIECE(TMP(1),"^",2)
SET ARET=-1
SET ARET("ISSUANCE DATE")=$PIECE(TMP(1),"^",2)_"^"_$PIECE($PIECE(PND0,"^",6),".")
+18 SET DRGNM=$$GET1^DIQ(50,$PIECE(PND0,"^",9),.01)
+19 IF DRGNM'=$PIECE(TMP(1),"^",3)
SET ARET=-1
SET ARET("DRUG NAME")=$PIECE(TMP(1),"^",3)_"^"_DRGNM
+20 IF $PIECE(PND0,"^",10)'=$PIECE(TMP(1),"^",6)
SET ARET=-1
SET ARET("QTY PRESCRIBED")=$PIECE(TMP(1),"^",6)_"^"_$PIECE(PND0,"^",10)
+21 ;provider info
+22 SET INST=$PIECE($GET(^PS(52.41,PNP,"INI")),"^")
+23 ;*545
+24 SET DEA=$$RXDEA^PSOUTIL(,ORP)
+25 IF DEA'=$PIECE(TMP(2),"^")
SET ARET=-1
SET ARET("DEA #")=$PIECE(TMP(2),"^")_"^"_DEA
+26 SET NAM=$$GET1^DIQ(200,$PIECE(PND0,"^",5),.01)
IF NAM'=$PIECE(TMP(2),"^",3)
SET ARET=-1
SET ARET("PROVIDER NAME")=$PIECE(TMP(2),"^",3)_"^"_NAM
+27 ;patient inf
+28 SET DFN=$PIECE(PND0,"^",2)
DO DEM^VADPT
DO ADD^VADPT
+29 IF VADM(1)'=$PIECE(TMP(4),"^")
SET ARET=-1
SET ARET("PATIENT NAME")=$PIECE(TMP(4),"^")_"^"_VADM(1)
+30 IF VAPA(1)'=$PIECE(TMP(5),"^")
SET ARET=-1
SET ARET("PATIENT ADDRESS #1")=$PIECE(TMP(5),"^")_"^"_VAPA(1)
+31 IF VAPA(2)'=$PIECE(TMP(5),"^",2)
SET ARET=-1
SET ARET("PATIENT ADDRESS #2")=$PIECE(TMP(5),"^",2)_"^"_VAPA(2)
+32 IF VAPA(3)'=$PIECE(TMP(5),"^",3)
SET ARET=-1
SET ARET("PATIENT ADDRESS #3")=$PIECE(TMP(5),"^",3)_"^"_VAPA(3)
+33 IF VAPA(4)'=$PIECE(TMP(5),"^",4)
SET ARET=-1
SET ARET("PATIENT CITY")=$PIECE(TMP(5),"^",4)_"^"_VAPA(4)
+34 IF $PIECE(VAPA(5),"^",2)'=$PIECE(TMP(5),"^",5)
SET ARET=-1
SET ARET("PATIENT STATE")=$PIECE(TMP(5),"^",5)_"^"_$PIECE(VAPA(5),"^",2)
+35 IF VAPA(6)'=$PIECE(TMP(5),"^",6)
SET ARET=-1
SET ARET("PATIENT ZIP+4")=$PIECE(TMP(5),"^",6)_"^"_VAPA(6)
+36 ;sig
+37 MERGE ASIG=^TMP($JOB,"ORDEA",ORP,6)
+38 SET I=0
FOR
SET I=$ORDER(^PS(52.41,PNP,1,I))
if 'I
QUIT
Begin DoDot:1
+39 SET INF0=$GET(^PS(52.41,PNP,9,I,0))
SET INF1=$GET(^PS(52.41,PNP,1,I,1))
+40 SET PSIG(I)=INF0_"|"_$PIECE(INF1,"^")_"|"_$PIECE(INF1,"^",2)_"|"_$PIECE(INF1,"^",6)_"|"_$PIECE(INF1,"^",8)
End DoDot:1
+41 SET I=0
FOR
SET I=$ORDER(ASIG(I))
if 'I
QUIT
IF ASIG(I)'=$GET(PSIG(I))
SET ND="SIG #"_I
SET ARET=-1
SET ARET(ND)=ASIG(I)_"^"_$GET(PSIG(I))
+42 DO KVA^VADPT
+43 KILL ^TMP($JOB,"ORDEA")
+44 QUIT $SELECT($GET(ARET):ARET,1:1)
+45 ;
ALERT ;
+1 ; ORN=76 - Notification ID (ifn from OE/RR Notifications file #100.9)
+2 ; ORBDFN=Patient DFN from Patient file #2
+3 ; ORNUM=Order ifn from Order file #100
+4 ; ORBADUZ=Provider DUZ - Array of notification recipients requested by the calling package.
+5 ; ORBPMSG=Message text
+6 ; ORBPDATA=This is an identifier of the package entry which the notification is based on.
+7 ; For radiology: Rad/Nuc Med exam/case ifn's(format: exam_ifn;case_ifn)
+8 ; For consults: the IEN of the consult in file 123
+9 NEW PSOX
SET PSOX=1
+10 SET PSOX(+$PIECE(OR0,"^",5))=""
+11 ;PSO*7*630
DO EN^ORB3(76,PSODFN,$PIECE(OR0,"^"),.PSOX,"Rx processed: PIV Card Cert Expired - NO ACTION REQ","")
+12 QUIT
+13 ;
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 ;;Rx NOT processed: PIV Card Certificate Revoked;;
18 ;;Verification failure;;
19 ;;Before Cert effective date;;
20 ;;Rx processed: PIV Card Cert Expired - NO ACTION REQ;;
21 ;;No Cert with a valid date found;;
22 ;;Signature Check failed (Invalid Signature);;
23 ;;CERT_IS_NOT_TIME_NESTED;;
24 ;;CERT_IS_NOT_VALID_FOR_USAGE;;
25 ;;CERT_IS_UNTRUSTED_ROOT;;
26 ;;CERT_REVOCATION_STATUS_UNKNOWN;;
27 ;;CERT_IS_CYCLIC;;
28 ;;CERT_IS_PARTIAL_CHAIN;;
29 ;;CERT_CTL_IS_NOT_SIGNATURE_VALID;;
30 ;;CERT_CTL_IS_NOT_VALID_FOR_USAGE;;
