PSSPGXOR ;BIR/RTR - PHARMACOGENOMICS CPRS API ;09/20/07
;;1.0;PHARMACY DATA MANAGEMENT;**262**;9/30/97;Build 66
;
PGX(PSSORPT,PSSOLIST,PSSORPKG,PSSORDRG,PSSORDNM,PSSORSUP) ; CPRS API for pharmacogenomic order check
;PSSORPT = Patient IEN
;PSSOLIST - LITERAL
;PSSORPKG = Package, may not be needed since it was passed into BDA to get drug
;PSSORDRG = Drug (#50) IEN
;PSSORDNM = Order Number
;PSSORSUP = Suppress flag - 'M' to suppress Moderate checks, 'H' to suppress High checks, 'N' for no suppression
;Update parameters to allow multiple entries, and add order number for CPRS display
N PSSPGXOR,PSSOROI,PSSDRGOI,PSSORRET,PSSORPGX
S PSSPGXOR=1
S PSSOROI=$P($G(^PS(50.7,+$P($G(^PSDRUG(PSSORDRG,2)),"^"),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
S PSSDRGOI(PSSORDRG)=""
S PSSDRGOI(PSSORDRG,"DRUGNAME")=PSSOROI
D PGXOC^PSSPGX("PSSORPGX",PSSORPT,.PSSDRGOI,.PSSORRET,PSSORPKG)
Q
;
;
;Best Drug available
;Input:
;PSSBDAOI = Pharmacy Orderable Item
;PSSBDAPK = O for Outpatient, U for Unit Dose, I for IV, X for Non-VA Med
;Output:
;Null if no PGx eligible VA Product available or:
;File 50 IEN^GCNSEQNO^VUID
BDA(PSSBDAOI,PSSBDAPK) ; Find best drug available for PGx order check
N PSSBDL,PSSBDZ,PSSBDND,PSSBDND1,PSSBDND3,PSSBDGCN,PSSBDAR,PSSBDRSL,PSSBDCNT,PSSBDARP,PSSBDDAT,PSSBDEAR,PSSLA2,PSSLA3,PSSAPUSE,PSSBDRS2,PSSBDRS3,PSSAPFLG,PSSAPLP
I '$G(PSSBDAOI) Q ""
I $G(PSSBDAPK)'="O",$G(PSSBDAPK)'="U",$G(PSSBDAPK)'="I",$G(PSSBDAPK)'="X" Q ""
S (PSSBDCNT,PSSBDRSL)=0
S PSSBDL="" F S PSSBDL=$O(^PSDRUG("ASP",PSSBDAOI,PSSBDL)) Q:'PSSBDL!(PSSBDRSL) D
.S PSSBDZ=$G(^PSDRUG(PSSBDL,0)),PSSBDND=$G(^("ND"))
.S PSSAPUSE=$P($G(^PSDRUG(PSSBDL,2)),"^",3)
.S PSSBDND1=$P(PSSBDND,"^"),PSSBDND3=$P(PSSBDND,"^",3)
.I 'PSSBDND1!('PSSBDND3) Q
.I '$$PGX^PSNAPIS(PSSBDND1,PSSBDND3) Q
.I $P(PSSBDZ,"^",3)["S"!($E($P(PSSBDZ,"^",2),1,2)="XA") Q
.S PSSBDGCN=$P($$PROD0^PSNAPIS(PSSBDND1,PSSBDND3),"^",7) I PSSBDGCN="" Q
.S PSSBDAR(PSSBDL)=PSSBDGCN_"^"_PSSAPUSE_"^"_$P($G(^PSDRUG(PSSBDL,"I")),"^")_"^"_$$VUID(PSSBDND3),PSSBDCNT=1
.S PSSBDDAT=$S($P($G(^PSDRUG(PSSBDL,"I")),"^"):$P($G(^PSDRUG(PSSBDL,"I")),"^"),1:9999999)
.S PSSAPFLG=0
.I $P(PSSBDAR(PSSBDL),"^",2)["O" S PSSBDARP("O",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
.I $P(PSSBDAR(PSSBDL),"^",2)["I" S PSSBDARP("I",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
.I $P(PSSBDAR(PSSBDL),"^",2)["U" S PSSBDARP("U",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
.I $P(PSSBDAR(PSSBDL),"^",2)["X" S PSSBDARP("X",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
.I 'PSSAPFLG S PSSBDARP("Z",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
.S PSSBDEAR(PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
.I $P(PSSBDAR(PSSBDL),"^",2)[PSSBDAPK,('$P(PSSBDAR(PSSBDL),"^",3)) S PSSBDRSL=PSSBDL Q
.I $P(PSSBDAR(PSSBDL),"^",2)[PSSBDAPK,($P(PSSBDAR(PSSBDL),"^",3)>DT) S PSSBDRS2(PSSBDAPK,PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3) Q
.I '$P(PSSBDAR(PSSBDL),"^",3)!($P(PSSBDAR(PSSBDL),"^",3)>DT) D
..S PSSAPUSE=PSSAPUSE_"Z" F PSSAPLP=1:1:$L(PSSAPUSE) D
...S PSSBDRS3($E(PSSAPUSE,PSSAPLP),PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
I 'PSSBDCNT Q ""
I PSSBDRSL Q PSSBDRSL_"^"_$P(PSSBDAR(PSSBDRSL),"^")_"^"_$P(PSSBDAR(PSSBDRSL),"^",4)
I $D(PSSBDRS2) D S PSSBDRSL=$O(PSSBDRS2(PSSBDAPK,PSSLA3,"")) Q PSSBDRSL_"^"_$G(PSSBDARP(PSSBDAPK,PSSLA3,PSSBDRSL))
.S PSSLA3="" F S PSSLA3=$O(PSSBDRS2(PSSBDAPK,PSSLA3)) I '$O(PSSBDRS2(PSSBDAPK,PSSLA3)) Q
;Left with multiple entries that either do not match package, have an inactive date, or both
I PSSBDAPK="O" D I PSSBDRSL Q PSSBDRSL
.S PSSBDL=$$LASTP("UIXZ") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("O") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("U") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("I") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("X") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("Z") I PSSBDL S PSSBDRSL=PSSBDL Q
I PSSBDAPK="U" D I PSSBDRSL Q PSSBDRSL
.S PSSBDL=$$LASTP("IOXZ") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("U") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("I") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("O") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("X") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("Z") I PSSBDL S PSSBDRSL=PSSBDL Q
I PSSBDAPK="I" D I PSSBDRSL Q PSSBDRSL
.S PSSBDL=$$LASTP("UOXZ") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("I") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("U") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("O") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("X") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("Z") I PSSBDL S PSSBDRSL=PSSBDL Q
I PSSBDAPK="X" D I PSSBDRSL Q PSSBDRSL
.S PSSBDL=$$LASTP("OUIZ") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("X") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("O") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("U") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("I") I PSSBDL S PSSBDRSL=PSSBDL Q
.S PSSBDL=$$LAST("Z") I PSSBDL S PSSBDRSL=PSSBDL Q
S PSSLA2="" F S PSSLA2=$O(PSSBDEAR(PSSLA2)) I '$O(PSSBDEAR(PSSLA2)) Q
I PSSLA2="" Q ""
S PSSBDL=$O(PSSBDEAR(PSSLA2,"")) I PSSBDL Q PSSBDL_"^"_$P(PSSBDEAR(PSSLA2,PSSBDL),"^")_"^"_$P(PSSBDEAR(PSSLA2,PSSBDL),"^",2)
Q ""
;
VUID(PSSNDF3) ;Return VUID
N PSSVUID
I 'PSSNDF3 Q ""
S PSSVUID=$$GETVUID^XTID(50.68,,+PSSNDF3_",")
Q PSSVUID
;
LAST(PSSPK) ;
N PSSLA1,PSSLAL1,PSSLALF,PSSLALD
S (PSSLA1,PSSLALF,PSSLALD)="" F S PSSLA1=$O(PSSBDARP(PSSPK,PSSLA1)) Q:PSSLA1="" D
.S PSSLAL1="" F S PSSLAL1=$O(PSSBDARP(PSSPK,PSSLA1,PSSLAL1)) I '$O(PSSBDARP(PSSPK,PSSLA1,PSSLAL1)) D Q
..S PSSLALD=PSSLAL1_"^"_$G(PSSBDARP(PSSPK,PSSLA1,PSSLAL1)),PSSLALF=1
Q PSSLALD
;
LASTP(PSSLA4) ;
N PSSLARES,PSSLA5,PSSLA6,PSSLA7,PSSLA8,PSSLAZ,PSSLAV2,PSSLAV3 S PSSLARES=0
S PSSLA5=$E(PSSLA4,1),PSSLA6=$E(PSSLA4,2),PSSLA7=$E(PSSLA4,3),PSSLAZ=$E(PSSLA4,4)
F PSSLA8=PSSLA5,PSSLA6,PSSLA7,PSSLAZ Q:PSSLARES D
.S PSSLAV2="" F S PSSLAV2=$O(PSSBDRS3(PSSLA8,PSSLAV2)) Q:'PSSLAV2 D
..S PSSLAV3="" F S PSSLAV3=$O(PSSBDRS3(PSSLA8,PSSLAV2,PSSLAV3)) I '$O(PSSBDRS3(PSSLA8,PSSLAV2,PSSLAV3)) D Q
...S PSSLARES=PSSLAV3_"^"_$G(PSSBDRS3(PSSLA8,PSSLAV2,PSSLAV3))
Q PSSLARES
;
SETOR ;Set data for CPRS PGX check from PSSPHAR array
;Set ^TMP($J,LIST,ORDER NUMBER,COUNTER,"TEXT")
;Set ^TMP($J,LIST,ORDER NUMBER,COUNTER,"SEV")
N PSSXL,PSSXCT,PSSACT,PSSTEMPX,PSSSUB2,PSSQLRF,PSSGNW,PSSCREEN,PSSPUNC,PSSPUNCT,PSSORCTR,PSSMCT,PSSORVAG,PSSORVGN,PSSGVAL1,PSSGVAL2,PSSGVAL3,PSSGVAL4,PSSGVAL5,PSSORURL
S PSSORURL=$S($G(PSSURL)'="":$G(PSSURL),1:$P($G(^PS(59.7,1,"PGX")),"^"))
I $G(PSSHDRFG) D HDRDOWN Q
S PSSORCTR=0
S PSSSUB1="" F S PSSSUB1=$O(PSSPHAR(PSSSUB1)) Q:PSSSUB1="" D
.S PSSXL="" F S PSSXL=$O(PSSPHAR(PSSSUB1,PSSXL)) Q:PSSXL="" S PSSXCT=1,PSSORCTR=PSSORCTR+1 D
..S PSSCREEN=$S($G(PSSPHAR(PSSSUB1,PSSXL,"ACTION LONG"))=""&($G(PSSPHAR(PSSSUB1,PSSXL,"MONITORING LONG"))=""):1,1:0)
..S PSSACT=$S($G(PSSPHAR(PSSSUB1,PSSXL,"DISPLAY ACTION"))="Informational":"MEDIUM",$G(PSSPHAR(PSSSUB1,PSSXL,"DISPLAY ACTION"))="Interruptive":"HIGH",1:"NONE")
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"SEV")=PSSACT
..I PSSCREEN D Q
...S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")="Please perform a manual PGx Order check by using the Check Pharmacogenomic Interaction option for Drug: "
...S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_PSSOROI_"."_" Reason(s): "_$G(PSSPHAR(PSSSUB1,PSSXL,"SCREEN"))
...S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" For more details on VA National Pharmacogenomics Program go to: "_PSSORURL
..S PSSPUNC=$G(PSSPHAR(PSSSUB1,PSSXL,"DXID")),PSSPUNCT=0
..I $G(PSSPUNC)'="",$E(PSSPUNC,$L(PSSPUNC))'="." S PSSPUNCT=1
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")="Pharmacogenomic "_$S(PSSACT="NONE":"Order Check:",1:PSSACT_" Order Check: ")_PSSOROI
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" and "_$G(PSSPHAR(PSSSUB1,PSSXL,"DXID"))_$S(PSSPUNCT:".",1:"")
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" ACTION: "_$G(PSSPHAR(PSSSUB1,PSSXL,"ACTION LONG"))
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" MONITORING: "_$G(PSSPHAR(PSSSUB1,PSSXL,"MONITORING LONG"))
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" VA National Pharmacogenomics Program: "_PSSORURL
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" - Monograph Available"
..D ADDINFO^PSSPGXPR M ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"PGXMON")=^TMP($J,"PSSXWARN",PSSACT,PSSXL,"AI")
..S PSSORVGN="" S PSSORVAG=$P($G(^PSDRUG(PSSORDRG,"ND")),"^")
..I PSSORVAG S PSSORVGN=$$VAGN^PSNAPIS(PSSORVAG)
..K PSSGVAL3,PSSGVAL5 S PSSGVAL4=0 F PSSGVAL1=1:1 Q:'$D(PSSPHAR(PSSSUB1,PSSXL,"GENE",PSSGVAL1)) D
...S PSSGVAL2=$G(PSSPHAR(PSSSUB1,PSSXL,"GENE",PSSGVAL1,"GENE")) Q:PSSGVAL2=""!($D(PSSGVAL3(PSSGVAL2)))
...S PSSGVAL5=$S('PSSGVAL4:PSSGVAL2,1:PSSGVAL5_"/"_PSSGVAL2) S PSSGVAL4=1,PSSGVAL3(PSSGVAL2)=""
..S ^TMP($J,PSSOLIST,PSSORDNM,PSSORCTR,"PGXTITLE")=$G(PSSGVAL5)_" // "_$G(PSSORVGN)
Q
;
HDRDOWN ;Can't retrieve patient's gene data
NEW PSSTXT,PSSTXT1,PSSSUB1,PSSSUB2,PSSGENE
S PSSGENE=""
S PSSTXT="Pharmacogenomic lab data could not be retrieved at this time. "_PSSOROI
S PSSTXT1=" VA National Pharmacogenomics Program go to: "_$P($G(^PS(59.7,1,"PGX")),"^")
;S ^TMP($J,PSSOLIST,1,1,"SEV")=""
I +$D(PSSPHAR) S PSSSUB1="" F S PSSSUB1=$O(PSSPHAR("HIGH",PSSSUB1)) Q:PSSSUB1="" D Q
. S PSSSUB2="" F S PSSSUB2=$O(PSSPHAR("HIGH",PSSSUB1,"GENE",PSSSUB2)) Q:PSSSUB2="" D
..S PSSGENE=PSSGENE_$S(PSSGENE="":"",1:", ")_$G(PSSPHAR("HIGH",PSSSUB1,"GENE",PSSSUB2,"GENE"))
.S PSSTXT=PSSTXT_$S(PSSGENE="":"",1:" and ")_PSSGENE_". "
.S PSSTXT=PSSTXT_"ACTION: "_$G(PSSPHAR("HIGH",PSSSUB1,"ACTION LONG"))_" MONITORING: "_$G(PSSPHAR("HIGH",PSSSUB1,"MONITORING LONG"))
.S ^TMP($J,PSSOLIST,1,1,"TEXT")=PSSTXT_PSSTXT1
.S ^TMP($J,PSSOLIST,1,1,"SEV")="HIGH"
;
I '+$D(PSSPHAR) D
.S ^TMP($J,PSSOLIST,1,1,"SEV")=""
.S PSSGENE=$$GENE^PSSPGXU2()
.S ^TMP($J,PSSOLIST,1,1,"TEXT")=PSSTXT_$S(PSSGENE]"":" and ",1:"")_PSSGENE_"."_PSSTXT1
Q
;
INC ;
S PSSXCT=PSSXCT+1
Q
FORMAT(X) ;
N PSSW1,PSSW2,PSSQLC
S DIWL=1,DIWR=79,DIWF="" I $G(PSSQLRF) S DIWR=55
K ^UTILITY($J,"W")
D ^DIWP
I $G(PSSQLRF) S PSSQLC=1 D
.S PSSW1="" F S PSSW1=$O(^UTILITY($J,"W",PSSW1)) Q:PSSW1="" D
..S PSSW2="" F S PSSW2=$O(^UTILITY($J,"W",PSSW1,PSSW2)) Q:PSSW2="" D
...S ^TMP($J,"PSSXWARN",PSSACT,PSSXL,PSSXCT)=$S(PSSQLC=1:" GENOMIC FINDING: ",1:" ")_$G(^UTILITY($J,"W",PSSW1,PSSW2,0)) S PSSQLC=PSSQLC+1 D INC
I '$G(PSSQLRF) S PSSW1="" F S PSSW1=$O(^UTILITY($J,"W",PSSW1)) Q:PSSW1="" D
.S PSSW2="" F S PSSW2=$O(^UTILITY($J,"W",PSSW1,PSSW2)) Q:PSSW2="" D
..S ^TMP($J,"PSSXWARN",PSSACT,PSSXL,PSSXCT)=$G(^UTILITY($J,"W",PSSW1,PSSW2,0)) D INC
K ^UTILITY($J,"W"),PSSTEMPX
I '$G(PSSQLRF) S ^TMP($J,"PSSXWARN",PSSACT,PSSXL,PSSXCT)="" D INC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPGXOR 11144 printed Mar 25, 2026@15:58:12 Page 2
PSSPGXOR ;BIR/RTR - PHARMACOGENOMICS CPRS API ;09/20/07
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**262**;9/30/97;Build 66
+2 ;
PGX(PSSORPT,PSSOLIST,PSSORPKG,PSSORDRG,PSSORDNM,PSSORSUP) ; CPRS API for pharmacogenomic order check
+1 ;PSSORPT = Patient IEN
+2 ;PSSOLIST - LITERAL
+3 ;PSSORPKG = Package, may not be needed since it was passed into BDA to get drug
+4 ;PSSORDRG = Drug (#50) IEN
+5 ;PSSORDNM = Order Number
+6 ;PSSORSUP = Suppress flag - 'M' to suppress Moderate checks, 'H' to suppress High checks, 'N' for no suppression
+7 ;Update parameters to allow multiple entries, and add order number for CPRS display
+8 NEW PSSPGXOR,PSSOROI,PSSDRGOI,PSSORRET,PSSORPGX
+9 SET PSSPGXOR=1
+10 SET PSSOROI=$PIECE($GET(^PS(50.7,+$PIECE($GET(^PSDRUG(PSSORDRG,2)),"^"),0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+11 SET PSSDRGOI(PSSORDRG)=""
+12 SET PSSDRGOI(PSSORDRG,"DRUGNAME")=PSSOROI
+13 DO PGXOC^PSSPGX("PSSORPGX",PSSORPT,.PSSDRGOI,.PSSORRET,PSSORPKG)
+14 QUIT
+15 ;
+16 ;
+17 ;Best Drug available
+18 ;Input:
+19 ;PSSBDAOI = Pharmacy Orderable Item
+20 ;PSSBDAPK = O for Outpatient, U for Unit Dose, I for IV, X for Non-VA Med
+21 ;Output:
+22 ;Null if no PGx eligible VA Product available or:
+23 ;File 50 IEN^GCNSEQNO^VUID
BDA(PSSBDAOI,PSSBDAPK) ; Find best drug available for PGx order check
+1 NEW PSSBDL,PSSBDZ,PSSBDND,PSSBDND1,PSSBDND3,PSSBDGCN,PSSBDAR,PSSBDRSL,PSSBDCNT,PSSBDARP,PSSBDDAT,PSSBDEAR,PSSLA2,PSSLA3,PSSAPUSE,PSSBDRS2,PSSBDRS3,PSSAPFLG,PSSAPLP
+2 IF '$GET(PSSBDAOI)
QUIT ""
+3 IF $GET(PSSBDAPK)'="O"
IF $GET(PSSBDAPK)'="U"
IF $GET(PSSBDAPK)'="I"
IF $GET(PSSBDAPK)'="X"
QUIT ""
+4 SET (PSSBDCNT,PSSBDRSL)=0
+5 SET PSSBDL=""
FOR
SET PSSBDL=$ORDER(^PSDRUG("ASP",PSSBDAOI,PSSBDL))
if 'PSSBDL!(PSSBDRSL)
QUIT
Begin DoDot:1
+6 SET PSSBDZ=$GET(^PSDRUG(PSSBDL,0))
SET PSSBDND=$GET(^("ND"))
+7 SET PSSAPUSE=$PIECE($GET(^PSDRUG(PSSBDL,2)),"^",3)
+8 SET PSSBDND1=$PIECE(PSSBDND,"^")
SET PSSBDND3=$PIECE(PSSBDND,"^",3)
+9 IF 'PSSBDND1!('PSSBDND3)
QUIT
+10 IF '$$PGX^PSNAPIS(PSSBDND1,PSSBDND3)
QUIT
+11 IF $PIECE(PSSBDZ,"^",3)["S"!($EXTRACT($PIECE(PSSBDZ,"^",2),1,2)="XA")
QUIT
+12 SET PSSBDGCN=$PIECE($$PROD0^PSNAPIS(PSSBDND1,PSSBDND3),"^",7)
IF PSSBDGCN=""
QUIT
+13 SET PSSBDAR(PSSBDL)=PSSBDGCN_"^"_PSSAPUSE_"^"_$PIECE($GET(^PSDRUG(PSSBDL,"I")),"^")_"^"_$$VUID(PSSBDND3)
SET PSSBDCNT=1
+14 SET PSSBDDAT=$SELECT($PIECE($GET(^PSDRUG(PSSBDL,"I")),"^"):$PIECE($GET(^PSDRUG(PSSBDL,"I")),"^"),1:9999999)
+15 SET PSSAPFLG=0
+16 IF $PIECE(PSSBDAR(PSSBDL),"^",2)["O"
SET PSSBDARP("O",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
+17 IF $PIECE(PSSBDAR(PSSBDL),"^",2)["I"
SET PSSBDARP("I",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
+18 IF $PIECE(PSSBDAR(PSSBDL),"^",2)["U"
SET PSSBDARP("U",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
+19 IF $PIECE(PSSBDAR(PSSBDL),"^",2)["X"
SET PSSBDARP("X",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
+20 IF 'PSSAPFLG
SET PSSBDARP("Z",PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
+21 SET PSSBDEAR(PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
+22 IF $PIECE(PSSBDAR(PSSBDL),"^",2)[PSSBDAPK
IF ('$PIECE(PSSBDAR(PSSBDL),"^",3))
SET PSSBDRSL=PSSBDL
QUIT
+23 IF $PIECE(PSSBDAR(PSSBDL),"^",2)[PSSBDAPK
IF ($PIECE(PSSBDAR(PSSBDL),"^",3)>DT)
SET PSSBDRS2(PSSBDAPK,PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
QUIT
+24 IF '$PIECE(PSSBDAR(PSSBDL),"^",3)!($PIECE(PSSBDAR(PSSBDL),"^",3)>DT)
Begin DoDot:2
+25 SET PSSAPUSE=PSSAPUSE_"Z"
FOR PSSAPLP=1:1:$LENGTH(PSSAPUSE)
Begin DoDot:3
+26 SET PSSBDRS3($EXTRACT(PSSAPUSE,PSSAPLP),PSSBDDAT,PSSBDL)=PSSBDGCN_"^"_$$VUID(PSSBDND3)
End DoDot:3
End DoDot:2
End DoDot:1
+27 IF 'PSSBDCNT
QUIT ""
+28 IF PSSBDRSL
QUIT PSSBDRSL_"^"_$PIECE(PSSBDAR(PSSBDRSL),"^")_"^"_$PIECE(PSSBDAR(PSSBDRSL),"^",4)
+29 IF $DATA(PSSBDRS2)
Begin DoDot:1
+30 SET PSSLA3=""
FOR
SET PSSLA3=$ORDER(PSSBDRS2(PSSBDAPK,PSSLA3))
IF '$ORDER(PSSBDRS2(PSSBDAPK,PSSLA3))
QUIT
End DoDot:1
SET PSSBDRSL=$ORDER(PSSBDRS2(PSSBDAPK,PSSLA3,""))
QUIT PSSBDRSL_"^"_$GET(PSSBDARP(PSSBDAPK,PSSLA3,PSSBDRSL))
+31 ;Left with multiple entries that either do not match package, have an inactive date, or both
+32 IF PSSBDAPK="O"
Begin DoDot:1
+33 SET PSSBDL=$$LASTP("UIXZ")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+34 SET PSSBDL=$$LAST("O")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+35 SET PSSBDL=$$LAST("U")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+36 SET PSSBDL=$$LAST("I")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+37 SET PSSBDL=$$LAST("X")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+38 SET PSSBDL=$$LAST("Z")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
End DoDot:1
IF PSSBDRSL
QUIT PSSBDRSL
+39 IF PSSBDAPK="U"
Begin DoDot:1
+40 SET PSSBDL=$$LASTP("IOXZ")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+41 SET PSSBDL=$$LAST("U")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+42 SET PSSBDL=$$LAST("I")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+43 SET PSSBDL=$$LAST("O")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+44 SET PSSBDL=$$LAST("X")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+45 SET PSSBDL=$$LAST("Z")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
End DoDot:1
IF PSSBDRSL
QUIT PSSBDRSL
+46 IF PSSBDAPK="I"
Begin DoDot:1
+47 SET PSSBDL=$$LASTP("UOXZ")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+48 SET PSSBDL=$$LAST("I")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+49 SET PSSBDL=$$LAST("U")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+50 SET PSSBDL=$$LAST("O")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+51 SET PSSBDL=$$LAST("X")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+52 SET PSSBDL=$$LAST("Z")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
End DoDot:1
IF PSSBDRSL
QUIT PSSBDRSL
+53 IF PSSBDAPK="X"
Begin DoDot:1
+54 SET PSSBDL=$$LASTP("OUIZ")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+55 SET PSSBDL=$$LAST("X")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+56 SET PSSBDL=$$LAST("O")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+57 SET PSSBDL=$$LAST("U")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+58 SET PSSBDL=$$LAST("I")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
+59 SET PSSBDL=$$LAST("Z")
IF PSSBDL
SET PSSBDRSL=PSSBDL
QUIT
End DoDot:1
IF PSSBDRSL
QUIT PSSBDRSL
+60 SET PSSLA2=""
FOR
SET PSSLA2=$ORDER(PSSBDEAR(PSSLA2))
IF '$ORDER(PSSBDEAR(PSSLA2))
QUIT
+61 IF PSSLA2=""
QUIT ""
+62 SET PSSBDL=$ORDER(PSSBDEAR(PSSLA2,""))
IF PSSBDL
QUIT PSSBDL_"^"_$PIECE(PSSBDEAR(PSSLA2,PSSBDL),"^")_"^"_$PIECE(PSSBDEAR(PSSLA2,PSSBDL),"^",2)
+63 QUIT ""
+64 ;
VUID(PSSNDF3) ;Return VUID
+1 NEW PSSVUID
+2 IF 'PSSNDF3
QUIT ""
+3 SET PSSVUID=$$GETVUID^XTID(50.68,,+PSSNDF3_",")
+4 QUIT PSSVUID
+5 ;
LAST(PSSPK) ;
+1 NEW PSSLA1,PSSLAL1,PSSLALF,PSSLALD
+2 SET (PSSLA1,PSSLALF,PSSLALD)=""
FOR
SET PSSLA1=$ORDER(PSSBDARP(PSSPK,PSSLA1))
if PSSLA1=""
QUIT
Begin DoDot:1
+3 SET PSSLAL1=""
FOR
SET PSSLAL1=$ORDER(PSSBDARP(PSSPK,PSSLA1,PSSLAL1))
IF '$ORDER(PSSBDARP(PSSPK,PSSLA1,PSSLAL1))
Begin DoDot:2
+4 SET PSSLALD=PSSLAL1_"^"_$GET(PSSBDARP(PSSPK,PSSLA1,PSSLAL1))
SET PSSLALF=1
End DoDot:2
QUIT
End DoDot:1
+5 QUIT PSSLALD
+6 ;
LASTP(PSSLA4) ;
+1 NEW PSSLARES,PSSLA5,PSSLA6,PSSLA7,PSSLA8,PSSLAZ,PSSLAV2,PSSLAV3
SET PSSLARES=0
+2 SET PSSLA5=$EXTRACT(PSSLA4,1)
SET PSSLA6=$EXTRACT(PSSLA4,2)
SET PSSLA7=$EXTRACT(PSSLA4,3)
SET PSSLAZ=$EXTRACT(PSSLA4,4)
+3 FOR PSSLA8=PSSLA5,PSSLA6,PSSLA7,PSSLAZ
if PSSLARES
QUIT
Begin DoDot:1
+4 SET PSSLAV2=""
FOR
SET PSSLAV2=$ORDER(PSSBDRS3(PSSLA8,PSSLAV2))
if 'PSSLAV2
QUIT
Begin DoDot:2
+5 SET PSSLAV3=""
FOR
SET PSSLAV3=$ORDER(PSSBDRS3(PSSLA8,PSSLAV2,PSSLAV3))
IF '$ORDER(PSSBDRS3(PSSLA8,PSSLAV2,PSSLAV3))
Begin DoDot:3
+6 SET PSSLARES=PSSLAV3_"^"_$GET(PSSBDRS3(PSSLA8,PSSLAV2,PSSLAV3))
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+7 QUIT PSSLARES
+8 ;
SETOR ;Set data for CPRS PGX check from PSSPHAR array
+1 ;Set ^TMP($J,LIST,ORDER NUMBER,COUNTER,"TEXT")
+2 ;Set ^TMP($J,LIST,ORDER NUMBER,COUNTER,"SEV")
+3 NEW PSSXL,PSSXCT,PSSACT,PSSTEMPX,PSSSUB2,PSSQLRF,PSSGNW,PSSCREEN,PSSPUNC,PSSPUNCT,PSSORCTR,PSSMCT,PSSORVAG,PSSORVGN,PSSGVAL1,PSSGVAL2,PSSGVAL3,PSSGVAL4,PSSGVAL5,PSSORURL
+4 SET PSSORURL=$SELECT($GET(PSSURL)'="":$GET(PSSURL),1:$PIECE($GET(^PS(59.7,1,"PGX")),"^"))
+5 IF $GET(PSSHDRFG)
DO HDRDOWN
QUIT
+6 SET PSSORCTR=0
+7 SET PSSSUB1=""
FOR
SET PSSSUB1=$ORDER(PSSPHAR(PSSSUB1))
if PSSSUB1=""
QUIT
Begin DoDot:1
+8 SET PSSXL=""
FOR
SET PSSXL=$ORDER(PSSPHAR(PSSSUB1,PSSXL))
if PSSXL=""
QUIT
SET PSSXCT=1
SET PSSORCTR=PSSORCTR+1
Begin DoDot:2
+9 SET PSSCREEN=$SELECT($GET(PSSPHAR(PSSSUB1,PSSXL,"ACTION LONG"))=""&($GET(PSSPHAR(PSSSUB1,PSSXL,"MONITORING LONG"))=""):1,1:0)
+10 SET PSSACT=$SELECT($GET(PSSPHAR(PSSSUB1,PSSXL,"DISPLAY ACTION"))="Informational":"MEDIUM",$GET(PSSPHAR(PSSSUB1,PSSXL,"DISPLAY ACTION"))="Interruptive":"HIGH",1:"NONE")
+11 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"SEV")=PSSACT
+12 IF PSSCREEN
Begin DoDot:3
+13 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")="Please perform a manual PGx Order check by using the Check Pharmacogenomic Interaction option for Drug: "
+14 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_PSSOROI_"."_" Reason(s): "_$GET(PSSPHAR(PSSSUB1,PSSXL,"SCREEN"))
+15 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" For more details on VA National Pharmacogenomics Program go to: "_PSSORURL
End DoDot:3
QUIT
+16 SET PSSPUNC=$GET(PSSPHAR(PSSSUB1,PSSXL,"DXID"))
SET PSSPUNCT=0
+17 IF $GET(PSSPUNC)'=""
IF $EXTRACT(PSSPUNC,$LENGTH(PSSPUNC))'="."
SET PSSPUNCT=1
+18 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")="Pharmacogenomic "_$SELECT(PSSACT="NONE":"Order Check:",1:PSSACT_" Order Check: ")_PSSOROI
+19 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" and "_$GET(PSSPHAR(PSSSUB1,PSSXL,"DXID"))_$SELECT(PSSPUNCT:".",1:"")
+20 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" ACTION: "_$GET(PSSPHAR(PSSSUB1,PSSXL,"ACTION LONG"))
+21 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" MONITORING: "_$GET(PSSPHAR(PSSSUB1,PSSXL,"MONITORING LONG"))
+22 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" VA National Pharmacogenomics Program: "_PSSORURL
+23 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")=^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"TEXT")_" - Monograph Available"
+24 DO ADDINFO^PSSPGXPR
MERGE ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"PGXMON")=^TMP($JOB,"PSSXWARN",PSSACT,PSSXL,"AI")
+25 SET PSSORVGN=""
SET PSSORVAG=$PIECE($GET(^PSDRUG(PSSORDRG,"ND")),"^")
+26 IF PSSORVAG
SET PSSORVGN=$$VAGN^PSNAPIS(PSSORVAG)
+27 KILL PSSGVAL3,PSSGVAL5
SET PSSGVAL4=0
FOR PSSGVAL1=1:1
if '$DATA(PSSPHAR(PSSSUB1,PSSXL,"GENE",PSSGVAL1))
QUIT
Begin DoDot:3
+28 SET PSSGVAL2=$GET(PSSPHAR(PSSSUB1,PSSXL,"GENE",PSSGVAL1,"GENE"))
if PSSGVAL2=""!($DATA(PSSGVAL3(PSSGVAL2)))
QUIT
+29 SET PSSGVAL5=$SELECT('PSSGVAL4:PSSGVAL2,1:PSSGVAL5_"/"_PSSGVAL2)
SET PSSGVAL4=1
SET PSSGVAL3(PSSGVAL2)=""
End DoDot:3
+30 SET ^TMP($JOB,PSSOLIST,PSSORDNM,PSSORCTR,"PGXTITLE")=$GET(PSSGVAL5)_" // "_$GET(PSSORVGN)
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
HDRDOWN ;Can't retrieve patient's gene data
+1 NEW PSSTXT,PSSTXT1,PSSSUB1,PSSSUB2,PSSGENE
+2 SET PSSGENE=""
+3 SET PSSTXT="Pharmacogenomic lab data could not be retrieved at this time. "_PSSOROI
+4 SET PSSTXT1=" VA National Pharmacogenomics Program go to: "_$PIECE($GET(^PS(59.7,1,"PGX")),"^")
+5 ;S ^TMP($J,PSSOLIST,1,1,"SEV")=""
+6 IF +$DATA(PSSPHAR)
SET PSSSUB1=""
FOR
SET PSSSUB1=$ORDER(PSSPHAR("HIGH",PSSSUB1))
if PSSSUB1=""
QUIT
Begin DoDot:1
+7 SET PSSSUB2=""
FOR
SET PSSSUB2=$ORDER(PSSPHAR("HIGH",PSSSUB1,"GENE",PSSSUB2))
if PSSSUB2=""
QUIT
Begin DoDot:2
+8 SET PSSGENE=PSSGENE_$SELECT(PSSGENE="":"",1:", ")_$GET(PSSPHAR("HIGH",PSSSUB1,"GENE",PSSSUB2,"GENE"))
End DoDot:2
+9 SET PSSTXT=PSSTXT_$SELECT(PSSGENE="":"",1:" and ")_PSSGENE_". "
+10 SET PSSTXT=PSSTXT_"ACTION: "_$GET(PSSPHAR("HIGH",PSSSUB1,"ACTION LONG"))_" MONITORING: "_$GET(PSSPHAR("HIGH",PSSSUB1,"MONITORING LONG"))
+11 SET ^TMP($JOB,PSSOLIST,1,1,"TEXT")=PSSTXT_PSSTXT1
+12 SET ^TMP($JOB,PSSOLIST,1,1,"SEV")="HIGH"
End DoDot:1
QUIT
+13 ;
+14 IF '+$DATA(PSSPHAR)
Begin DoDot:1
+15 SET ^TMP($JOB,PSSOLIST,1,1,"SEV")=""
+16 SET PSSGENE=$$GENE^PSSPGXU2()
+17 SET ^TMP($JOB,PSSOLIST,1,1,"TEXT")=PSSTXT_$SELECT(PSSGENE]"":" and ",1:"")_PSSGENE_"."_PSSTXT1
End DoDot:1
+18 QUIT
+19 ;
INC ;
+1 SET PSSXCT=PSSXCT+1
+2 QUIT
FORMAT(X) ;
+1 NEW PSSW1,PSSW2,PSSQLC
+2 SET DIWL=1
SET DIWR=79
SET DIWF=""
IF $GET(PSSQLRF)
SET DIWR=55
+3 KILL ^UTILITY($JOB,"W")
+4 DO ^DIWP
+5 IF $GET(PSSQLRF)
SET PSSQLC=1
Begin DoDot:1
+6 SET PSSW1=""
FOR
SET PSSW1=$ORDER(^UTILITY($JOB,"W",PSSW1))
if PSSW1=""
QUIT
Begin DoDot:2
+7 SET PSSW2=""
FOR
SET PSSW2=$ORDER(^UTILITY($JOB,"W",PSSW1,PSSW2))
if PSSW2=""
QUIT
Begin DoDot:3
+8 SET ^TMP($JOB,"PSSXWARN",PSSACT,PSSXL,PSSXCT)=$SELECT(PSSQLC=1:" GENOMIC FINDING: ",1:" ")_$GET(^UTILITY($JOB,"W",PSSW1,PSSW2,0))
SET PSSQLC=PSSQLC+1
DO INC
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF '$GET(PSSQLRF)
SET PSSW1=""
FOR
SET PSSW1=$ORDER(^UTILITY($JOB,"W",PSSW1))
if PSSW1=""
QUIT
Begin DoDot:1
+10 SET PSSW2=""
FOR
SET PSSW2=$ORDER(^UTILITY($JOB,"W",PSSW1,PSSW2))
if PSSW2=""
QUIT
Begin DoDot:2
+11 SET ^TMP($JOB,"PSSXWARN",PSSACT,PSSXL,PSSXCT)=$GET(^UTILITY($JOB,"W",PSSW1,PSSW2,0))
DO INC
End DoDot:2
End DoDot:1
+12 KILL ^UTILITY($JOB,"W"),PSSTEMPX
+13 IF '$GET(PSSQLRF)
SET ^TMP($JOB,"PSSXWARN",PSSACT,PSSXL,PSSXCT)=""
DO INC
+14 QUIT
