- 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;;
