ORWOR1 ; SLC/DCM - PKI RPC functions ;03/27/13 4:57pm
;;3.0;ORDER ENTRY/RESULTS REPORTING;**132,141,163,306,371,499**;Dec 17, 1997;Build 165
;
;
;
;
SIG(RET,ID,X1,X2,X3,X4,ORX5,X6,X7) ;Store the signature.
;ID = orifn;action
;X1 = Hash
;X2 = Length of the array
;X3 = Datafile (100)
;X4 = Provider DUZ
;ORX5 = Array for the sig
;X6 = CRLURL
;X7 = DFN
;
N ORHINFO,ORDINFO,OROUT,ORADD
;gets patient/user specific info used in hash on GUI
K ORDFDA
D HASHINFO^ORDEA(.ORHINFO,X7,X4,+ID) ;*499
;get order specific info used in hash on GUI
D ORDHINFO^ORDEA(.ORDINFO,+ID,X1,.ORHINFO)
;look for existing entries in 101.52
S ORADD=1
I $D(^ORPA(101.52,"B",+ID)) D
.N ORI S ORI=0 F S ORI=$O(^ORPA(101.52,"B",+ID,ORI)) Q:'ORI D
..;if existing entry is not one that originated from backdoor and it's hash matches the current hash set flag to not add new record
..I ($L($P($G(^ORPA(101.52,ORI,0)),U,2))=0),$P($G(^ORPA(101.52,ORI,0)),U,3)=X1 D
...S ORADD=0
...;keep record that this was called but matched for 60 days
...S ^XTMP("OR DUP ARCHIVE","HMATCH",+ID,ORI,$$NOW^XLFDT)=""
...S ^XTMP("OR DUP ARCHIVE",0)=$$FMADD^XLFDT($$NOW^XLFDT,60)_U_$$NOW^XLFDT
..;if existing entry is not one that originated from backdoor but it does not match the current hash delete it
..I ($L($P($G(^ORPA(101.52,ORI,0)),U,2))=0),$P($G(^ORPA(101.52,ORI,0)),U,3)'=X1 D
...;keep deleted archive entry in xtmp for 60 days
...M ^XTMP("OR DUP ARCHIVE","HUNMATCH",+ID,ORI,$$NOW^XLFDT)=^ORPA(101.52,ORI)
...S ^XTMP("OR DUP ARCHIVE",0)=$$FMADD^XLFDT($$NOW^XLFDT,60)_U_$$NOW^XLFDT
...N DA,DIK
...S DA=ORI,DIK="^ORPA(101.52," D ^DIK
..;if it is from backdoor then update that record with the hash and set flag to not add new record
..I $L($P($G(^ORPA(101.52,ORI,0)),U,2))>0 S $P(^ORPA(101.52,ORI,0),U,3)=X1 S ORADD=0
I ORADD D UPDATE^DIE("","ORDFDA","OROUT","ERROR") K ORDFDA
S Y1=$$STORESIG^XUSSPKI(X1,X2,.ORX5,X4,X3)
I +Y1>0 D
. S ORIFN=+ID,ACT=$P(ID,";",2)
. S $P(^OR(100,ORIFN,8,+ACT,2),"^",3)=X1
S RET=1
Q
CRLURL(RET,X1) ;Store the URL's
S RET=$$CRLURL^XUSSPKI(X1)
Q
VERIFY(RET,ORDER,DFN) ;Verify PKI Data
;DBIA #3750
;ORDER = 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 ORIFN,ORACTION,HASH,DATE
K ^TMP("ORPKIDATA",$J)
I '$G(ORDER) S RET="-1^No order number passed" Q
I '$G(DFN) S RET="-1^No DFN passed" Q
S ORIFN=$P(ORDER,";"),ORACTION=$P(ORDER,";",2)
I 'ORACTION S ORACTION=1
I '$D(^OR(100,ORIFN,0)) S RET="-1^Invalid order number" Q
I DFN'=+$P(^OR(100,ORIFN,0),"^",2) S RET="-1^DFN does not match patient on order" Q
I '$D(^OR(100,ORIFN,8,ORACTION)) S RET="-1^Invalid order action passed" Q
S HASH=$P($G(^OR(100,ORIFN,8,ORACTION,2)),"^",3)
I '$L(HASH) S RET="-1^Order has no PKI Hash" Q
I '$O(^OR(100,ORIFN,8,ORACTION,.2,0)) S RET="-1^Order has no PKI Data" Q
S DATE=$P($G(^OR(100,ORIFN,8,ORACTION,.2,1,0)),"^")
I '$L(DATE) S RET="-1^No date associated with PKI Data" Q
S DATE=$$HL7TFM^XLFDT(DATE),I=0
F S I=$O(^OR(100,ORIFN,8,ORACTION,.2,I)) Q:'I S ^TMP("ORPKIDATA",$J,I)=^(I,0)
S RET=$$VERIFY^XUSSPKI(HASH,$NA(^TMP("ORPKIDATA",$J)),DATE)
I RET="OK" S RET=1 Q
I $E(RET,1,7)="-898020" S RET=$E(RET,2,99)
Q
CHKDIG(REQ,ORDER) ;Check if Digital Signature is required
N IFN,ACTION
S REQ=0,IFN=+ORDER,ACTION=$P(ORDER,";",2)
I +$P($G(^OR(100,+IFN,8,+ACTION,2)),U,5) S REQ=1
Q
GETDTEXT(TEXT,ORDER) ;Get External Text
N IFN,ACTION
S IFN=+ORDER,ACTION=$P(ORDER,";",2),I=0
F S I=$O(^OR(100,+IFN,8,+ACTION,.2,I)) Q:'I S TEXT(I)=^(I,0)
Q
GETDSIG(SIG,ORDER) ;Get Digital Signature
N IFN,ACTION
S SIG=0,IFN=+ORDER,ACTION=$P(ORDER,";",2)
I +$P($G(^OR(100,+IFN,8,+ACTION,2)),U,3) S SIG=$P(^(2),"^",3)
Q
GETDEA(Y,ORUSER) ;Get user DEA
S Y=$$DEA^XUSER(,$G(ORUSER))
Q
GETDSCH(Y,ORDER) ;Check if Drug Schedule
N IFN,ACTION
S IFN=+ORDER,ACTION=$P(ORDER,";",2)
S Y=$P($G(^OR(100,+IFN,8,+ACTION,2)),U,4)
Q
SETDTEXT(Y,ORDER,ORDEA,ORSIGNER) ;Set Digital Text data into file 100 & return the array
;ORDER = ORIFN;ACTION
;ORDEA = Schedule of Drug (2-5)
;ORSIGNER = DUZ of signer
N ORSET,IFN,ACT,I
S Y="-1^Digital Text failed to build",IFN=+ORDER,ACT=$P(ORDER,";",2)
I '$G(ORDEA) Q
I '$G(ORSIGNER) S ORSIGNER=DUZ
D DIGTEXT^ORCSAVE1(IFN,ORDEA,ORSIGNER)
S Y=0
I '$G(ORSET) Q
K ^OR(100,IFN,8,ACT,.2)
F I=1:1:ORSET S (Y(I),^OR(100,IFN,8,ACT,.2,I,0))=ORSET(I)
S ^OR(100,IFN,8,ACT,.2,0)="^^"_ORSET_"^"_ORSET_"^"_DT_"^",Y=ORSET
Q
GETDATA(Y,ORDER,DFN) ;Get PKI Data
;DBIA #3750
;On error: Y = -1^Error message
;Else: Y = 1^ Order # ^ Nature of order ^ Order Status ^ Date Signed
;Y(1) = Patient name ^ Street1 ^ Street2 ^ Street3 ^ City ^ State ^ Zip
;Y(2) = Drug name_strength_dosage form (Dispense drug) ^ Drug IEN (file 50) ^ Drug quantity prescribed ^ Schedule of medication ^ DEA Schedule
;Y(3) = Directions for use (SIG)
;Y(4) = Practitioner's name ^ DUZ ^ Practitioner's (DEA) registration number
;Y(5) = SiteName ^ SiteStreet1 ^ SiteStreet2 ^ SiteCity ^ SiteState ^ SiteZip
;Y(6) = Orderable Item ^ Orderable Item IEN (file 101.43)
N X0,X1,X2,X3,X4,X5,X6,ORNAT,ORSTAT
I '$D(^OR(100,+$G(ORDER),0)) S Y="-1^INVALID ORDER #" Q
I $G(DFN)'=+$P(^OR(100,ORDER,0),"^",2) S Y="-1^INVALID PATIENT ID" Q
I '$D(^OR(100,ORDER,8,1,.2,0)) S Y="-1^MISSING DIGITAL SIGNATURE TEXT" Q
S X0=$G(^OR(100,ORDER,8,1,0))
I $P($G(^OR(100,ORDER,8,1,0)),"^",4)'=7 S Y="-1^ORDER HAS NOT BEEN DIGITALLY SIGNED" Q
S X1=$G(^OR(100,ORDER,8,1,.2,1,0))
I DFN'=$P(X1,"^",4) S Y="-1^PKI PATIENT ID DOES NOT MATCH DFN" Q
S ORNAT=$P(X0,"^",12),ORSTAT=$P($G(^OR(100,ORDER,3)),"^",3)
I ORNAT S ORNAT=$P($G(^ORD(100.02,ORNAT,0)),"^")
I ORSTAT S ORSTAT=ORSTAT_";"_$P(^ORD(100.01,ORSTAT,0),"^")
S Y="1^"_ORDER_"^"_ORNAT_"^"_ORSTAT_"^"_$P(X0,"^",6)
S X2=$G(^OR(100,ORDER,8,1,.2,2,0)),X3=$G(^OR(100,ORDER,8,1,.2,3,0)),X4=$G(^OR(100,ORDER,8,1,.2,4,0)),X5=$G(^OR(100,ORDER,8,1,.2,5,0)),X6=$G(^OR(100,ORDER,8,1,.2,6,0))
S X3=$$VALUE^ORX8(ORDER,"DRUG",,"E")_"^"_$$VALUE^ORX8(ORDER,"DRUG",,"I")_"^"_$P(X3,"^",3,99)
S Y(1)=$P(X1,"^",2)_"^"_X2
S Y(2)=X3,Y(3)=X4,Y(4)=X5,Y(5)=X6
S Y(6)=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E")_"^"_$$VALUE^ORX8(ORDER,"ORDERABLE",,"I")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWOR1 6497 printed Sep 23, 2025@20:13:09 Page 2
ORWOR1 ; SLC/DCM - PKI RPC functions ;03/27/13 4:57pm
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**132,141,163,306,371,499**;Dec 17, 1997;Build 165
+2 ;
+3 ;
+4 ;
+5 ;
SIG(RET,ID,X1,X2,X3,X4,ORX5,X6,X7) ;Store the signature.
+1 ;ID = orifn;action
+2 ;X1 = Hash
+3 ;X2 = Length of the array
+4 ;X3 = Datafile (100)
+5 ;X4 = Provider DUZ
+6 ;ORX5 = Array for the sig
+7 ;X6 = CRLURL
+8 ;X7 = DFN
+9 ;
+10 NEW ORHINFO,ORDINFO,OROUT,ORADD
+11 ;gets patient/user specific info used in hash on GUI
+12 KILL ORDFDA
+13 ;*499
DO HASHINFO^ORDEA(.ORHINFO,X7,X4,+ID)
+14 ;get order specific info used in hash on GUI
+15 DO ORDHINFO^ORDEA(.ORDINFO,+ID,X1,.ORHINFO)
+16 ;look for existing entries in 101.52
+17 SET ORADD=1
+18 IF $DATA(^ORPA(101.52,"B",+ID))
Begin DoDot:1
+19 NEW ORI
SET ORI=0
FOR
SET ORI=$ORDER(^ORPA(101.52,"B",+ID,ORI))
if 'ORI
QUIT
Begin DoDot:2
+20 ;if existing entry is not one that originated from backdoor and it's hash matches the current hash set flag to not add new record
+21 IF ($LENGTH($PIECE($GET(^ORPA(101.52,ORI,0)),U,2))=0)
IF $PIECE($GET(^ORPA(101.52,ORI,0)),U,3)=X1
Begin DoDot:3
+22 SET ORADD=0
+23 ;keep record that this was called but matched for 60 days
+24 SET ^XTMP("OR DUP ARCHIVE","HMATCH",+ID,ORI,$$NOW^XLFDT)=""
+25 SET ^XTMP("OR DUP ARCHIVE",0)=$$FMADD^XLFDT($$NOW^XLFDT,60)_U_$$NOW^XLFDT
End DoDot:3
+26 ;if existing entry is not one that originated from backdoor but it does not match the current hash delete it
+27 IF ($LENGTH($PIECE($GET(^ORPA(101.52,ORI,0)),U,2))=0)
IF $PIECE($GET(^ORPA(101.52,ORI,0)),U,3)'=X1
Begin DoDot:3
+28 ;keep deleted archive entry in xtmp for 60 days
+29 MERGE ^XTMP("OR DUP ARCHIVE","HUNMATCH",+ID,ORI,$$NOW^XLFDT)=^ORPA(101.52,ORI)
+30 SET ^XTMP("OR DUP ARCHIVE",0)=$$FMADD^XLFDT($$NOW^XLFDT,60)_U_$$NOW^XLFDT
+31 NEW DA,DIK
+32 SET DA=ORI
SET DIK="^ORPA(101.52,"
DO ^DIK
End DoDot:3
+33 ;if it is from backdoor then update that record with the hash and set flag to not add new record
+34 IF $LENGTH($PIECE($GET(^ORPA(101.52,ORI,0)),U,2))>0
SET $PIECE(^ORPA(101.52,ORI,0),U,3)=X1
SET ORADD=0
End DoDot:2
End DoDot:1
+35 IF ORADD
DO UPDATE^DIE("","ORDFDA","OROUT","ERROR")
KILL ORDFDA
+36 SET Y1=$$STORESIG^XUSSPKI(X1,X2,.ORX5,X4,X3)
+37 IF +Y1>0
Begin DoDot:1
+38 SET ORIFN=+ID
SET ACT=$PIECE(ID,";",2)
+39 SET $PIECE(^OR(100,ORIFN,8,+ACT,2),"^",3)=X1
End DoDot:1
+40 SET RET=1
+41 QUIT
CRLURL(RET,X1) ;Store the URL's
+1 SET RET=$$CRLURL^XUSSPKI(X1)
+2 QUIT
VERIFY(RET,ORDER,DFN) ;Verify PKI Data
+1 ;DBIA #3750
+2 ;ORDER = ORIFN;ACTION - NOTE: if no ACTION then 1 (new order) is assumed
+3 ;Returned values: "1" if digital signature verifies
+4 ; "-1^error message" if DS fails during initial parameter checking
+5 ; "898020xx^message" if DS fails during verification
+6 NEW ORIFN,ORACTION,HASH,DATE
+7 KILL ^TMP("ORPKIDATA",$JOB)
+8 IF '$GET(ORDER)
SET RET="-1^No order number passed"
QUIT
+9 IF '$GET(DFN)
SET RET="-1^No DFN passed"
QUIT
+10 SET ORIFN=$PIECE(ORDER,";")
SET ORACTION=$PIECE(ORDER,";",2)
+11 IF 'ORACTION
SET ORACTION=1
+12 IF '$DATA(^OR(100,ORIFN,0))
SET RET="-1^Invalid order number"
QUIT
+13 IF DFN'=+$PIECE(^OR(100,ORIFN,0),"^",2)
SET RET="-1^DFN does not match patient on order"
QUIT
+14 IF '$DATA(^OR(100,ORIFN,8,ORACTION))
SET RET="-1^Invalid order action passed"
QUIT
+15 SET HASH=$PIECE($GET(^OR(100,ORIFN,8,ORACTION,2)),"^",3)
+16 IF '$LENGTH(HASH)
SET RET="-1^Order has no PKI Hash"
QUIT
+17 IF '$ORDER(^OR(100,ORIFN,8,ORACTION,.2,0))
SET RET="-1^Order has no PKI Data"
QUIT
+18 SET DATE=$PIECE($GET(^OR(100,ORIFN,8,ORACTION,.2,1,0)),"^")
+19 IF '$LENGTH(DATE)
SET RET="-1^No date associated with PKI Data"
QUIT
+20 SET DATE=$$HL7TFM^XLFDT(DATE)
SET I=0
+21 FOR
SET I=$ORDER(^OR(100,ORIFN,8,ORACTION,.2,I))
if 'I
QUIT
SET ^TMP("ORPKIDATA",$JOB,I)=^(I,0)
+22 SET RET=$$VERIFY^XUSSPKI(HASH,$NAME(^TMP("ORPKIDATA",$JOB)),DATE)
+23 IF RET="OK"
SET RET=1
QUIT
+24 IF $EXTRACT(RET,1,7)="-898020"
SET RET=$EXTRACT(RET,2,99)
+25 QUIT
CHKDIG(REQ,ORDER) ;Check if Digital Signature is required
+1 NEW IFN,ACTION
+2 SET REQ=0
SET IFN=+ORDER
SET ACTION=$PIECE(ORDER,";",2)
+3 IF +$PIECE($GET(^OR(100,+IFN,8,+ACTION,2)),U,5)
SET REQ=1
+4 QUIT
GETDTEXT(TEXT,ORDER) ;Get External Text
+1 NEW IFN,ACTION
+2 SET IFN=+ORDER
SET ACTION=$PIECE(ORDER,";",2)
SET I=0
+3 FOR
SET I=$ORDER(^OR(100,+IFN,8,+ACTION,.2,I))
if 'I
QUIT
SET TEXT(I)=^(I,0)
+4 QUIT
GETDSIG(SIG,ORDER) ;Get Digital Signature
+1 NEW IFN,ACTION
+2 SET SIG=0
SET IFN=+ORDER
SET ACTION=$PIECE(ORDER,";",2)
+3 IF +$PIECE($GET(^OR(100,+IFN,8,+ACTION,2)),U,3)
SET SIG=$PIECE(^(2),"^",3)
+4 QUIT
GETDEA(Y,ORUSER) ;Get user DEA
+1 SET Y=$$DEA^XUSER(,$GET(ORUSER))
+2 QUIT
GETDSCH(Y,ORDER) ;Check if Drug Schedule
+1 NEW IFN,ACTION
+2 SET IFN=+ORDER
SET ACTION=$PIECE(ORDER,";",2)
+3 SET Y=$PIECE($GET(^OR(100,+IFN,8,+ACTION,2)),U,4)
+4 QUIT
SETDTEXT(Y,ORDER,ORDEA,ORSIGNER) ;Set Digital Text data into file 100 & return the array
+1 ;ORDER = ORIFN;ACTION
+2 ;ORDEA = Schedule of Drug (2-5)
+3 ;ORSIGNER = DUZ of signer
+4 NEW ORSET,IFN,ACT,I
+5 SET Y="-1^Digital Text failed to build"
SET IFN=+ORDER
SET ACT=$PIECE(ORDER,";",2)
+6 IF '$GET(ORDEA)
QUIT
+7 IF '$GET(ORSIGNER)
SET ORSIGNER=DUZ
+8 DO DIGTEXT^ORCSAVE1(IFN,ORDEA,ORSIGNER)
+9 SET Y=0
+10 IF '$GET(ORSET)
QUIT
+11 KILL ^OR(100,IFN,8,ACT,.2)
+12 FOR I=1:1:ORSET
SET (Y(I),^OR(100,IFN,8,ACT,.2,I,0))=ORSET(I)
+13 SET ^OR(100,IFN,8,ACT,.2,0)="^^"_ORSET_"^"_ORSET_"^"_DT_"^"
SET Y=ORSET
+14 QUIT
GETDATA(Y,ORDER,DFN) ;Get PKI Data
+1 ;DBIA #3750
+2 ;On error: Y = -1^Error message
+3 ;Else: Y = 1^ Order # ^ Nature of order ^ Order Status ^ Date Signed
+4 ;Y(1) = Patient name ^ Street1 ^ Street2 ^ Street3 ^ City ^ State ^ Zip
+5 ;Y(2) = Drug name_strength_dosage form (Dispense drug) ^ Drug IEN (file 50) ^ Drug quantity prescribed ^ Schedule of medication ^ DEA Schedule
+6 ;Y(3) = Directions for use (SIG)
+7 ;Y(4) = Practitioner's name ^ DUZ ^ Practitioner's (DEA) registration number
+8 ;Y(5) = SiteName ^ SiteStreet1 ^ SiteStreet2 ^ SiteCity ^ SiteState ^ SiteZip
+9 ;Y(6) = Orderable Item ^ Orderable Item IEN (file 101.43)
+10 NEW X0,X1,X2,X3,X4,X5,X6,ORNAT,ORSTAT
+11 IF '$DATA(^OR(100,+$GET(ORDER),0))
SET Y="-1^INVALID ORDER #"
QUIT
+12 IF $GET(DFN)'=+$PIECE(^OR(100,ORDER,0),"^",2)
SET Y="-1^INVALID PATIENT ID"
QUIT
+13 IF '$DATA(^OR(100,ORDER,8,1,.2,0))
SET Y="-1^MISSING DIGITAL SIGNATURE TEXT"
QUIT
+14 SET X0=$GET(^OR(100,ORDER,8,1,0))
+15 IF $PIECE($GET(^OR(100,ORDER,8,1,0)),"^",4)'=7
SET Y="-1^ORDER HAS NOT BEEN DIGITALLY SIGNED"
QUIT
+16 SET X1=$GET(^OR(100,ORDER,8,1,.2,1,0))
+17 IF DFN'=$PIECE(X1,"^",4)
SET Y="-1^PKI PATIENT ID DOES NOT MATCH DFN"
QUIT
+18 SET ORNAT=$PIECE(X0,"^",12)
SET ORSTAT=$PIECE($GET(^OR(100,ORDER,3)),"^",3)
+19 IF ORNAT
SET ORNAT=$PIECE($GET(^ORD(100.02,ORNAT,0)),"^")
+20 IF ORSTAT
SET ORSTAT=ORSTAT_";"_$PIECE(^ORD(100.01,ORSTAT,0),"^")
+21 SET Y="1^"_ORDER_"^"_ORNAT_"^"_ORSTAT_"^"_$PIECE(X0,"^",6)
+22 SET X2=$GET(^OR(100,ORDER,8,1,.2,2,0))
SET X3=$GET(^OR(100,ORDER,8,1,.2,3,0))
SET X4=$GET(^OR(100,ORDER,8,1,.2,4,0))
SET X5=$GET(^OR(100,ORDER,8,1,.2,5,0))
SET X6=$GET(^OR(100,ORDER,8,1,.2,6,0))
+23 SET X3=$$VALUE^ORX8(ORDER,"DRUG",,"E")_"^"_$$VALUE^ORX8(ORDER,"DRUG",,"I")_"^"_$PIECE(X3,"^",3,99)
+24 SET Y(1)=$PIECE(X1,"^",2)_"^"_X2
+25 SET Y(2)=X3
SET Y(3)=X4
SET Y(4)=X5
SET Y(5)=X6
+26 SET Y(6)=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E")_"^"_$$VALUE^ORX8(ORDER,"ORDERABLE",,"I")
+27 QUIT
