PSSPGXT1 ;BIR/RTR - PHARMACOGENOMICS TEST OPTION CONTINUED;09/20/07
;;1.0;PHARMACY DATA MANAGEMENT;**262**;9/30/97;Build 66
;
;Reference to BLD^PSOOCPGX is supported by ICR #7527
;Reference to EHCHK^PSJORUT2 is supported by ICR #2376
;
ASK() ;
N DIR,DUOUT,DIRUT,DTOUT,X,Y
S DIR(0)="Y",DIR("?")=" ",DIR("?",1)="Enter 'YES' to use a patients genomic lab data for the input,"
S DIR("?",2)="enter 'NO' to select genomic data for the input."
S DIR("A")="Do you want to use a specific patient",DIR("B")="Y"
D ^DIR K DIR I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSSASKQT=1 Q 0
Q Y
;
ASKPT ;
N DIR,DUOUT,DIRUT,DTOUT,X,Y
W ! S DIC=2,DIC(0)="QEAM" D ^DIC I Y'>0!($D(DUOUT))!($D(DTOUT)) Q
S PSSTESTP=+Y
Q
;
ASKDR ;
N DIR,DUOUT,DIRUT,DTOUT,X,Y,PSSNVAL,PSSNVA0,PSSNVAC,PSSNVACP,PSSNVADG,PSSPPRF,PSSPPRF1,PSSPPRFP,PSSPPRFC,PSSPPRFA,PSSPPRFL,PSSPPRFZ
S DIR(0)="Y",DIR("?")=" ",DIR("?",1)="Enter 'YES' to use the patients PGX eligible active drugs as prospective drugs,"
S DIR("?",2)="enter 'NO' to select prospective drugs."
S DIR("A",1)="Do you want to use the patient's pharmacogenomic eligible drug(s)",DIR("A")="from their medication profile(s)",DIR("B")="Y"
D ^DIR K DIR I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSSASKQT=1 Q
S PSSPDRUG=Y
I 'PSSPDRUG Q
K ^TMP($J,"ORDERS") D ENCHK^PSJORUT2(PSSTESTP,0) I $D(^TMP($J,"ORDERS")) D REBUILDI,CHECK
D BLD^PSOOCPGX(PSSTESTP,90) I $D(^TMP($J,"ORDERS")) D REBUILD,CHECK
S PSSNVAC=1
S PSSNVAL="" F S PSSNVAL=$O(^PS(55,PSSTESTP,"NVA",PSSNVAL)) Q:PSSNVAL="" D
.S PSSNVA0=$G(^PS(55,PSSTESTP,"NVA",PSSNVAL,0))
.I $P(PSSNVA0,"^",6) Q
.I $P(PSSNVA0,"^",7),$P(PSSNVA0,"^",7)<DT Q
.I '$P(PSSNVA0,"^"),'$P(PSSNVA0,"^",2) Q
.S PSSNVADG=$P(PSSNVA0,"^",2)
.I 'PSSNVADG S PSSNVADG=+$$BDA^PSSPGXOR($P(PSSNVA0,"^"),"X")
.I 'PSSNVADG Q
.S PSSNVACP=$G(^PSDRUG(PSSNVADG,"ND"))
.S ^TMP($J,"ORDERS",PSSNVAC)="^"_$P(PSSNVACP,"^")_"A"_$P(PSSNVACP,"^",3)_"^"_$P($G(^PSDRUG(PSSNVADG,0)),"^")_"^^"_PSSNVAC_"X;O"
.S PSSNVAC=PSSNVAC+1
I $D(^TMP($J,"ORDERS")) D CHECK
W @IOF
I '$D(PSSPGXDG) W !,"Patient does not have any pharmacogenomic eligible drugs",!,"on their medication profile.",! D PAUSE2^PSSPGXTS Q
W !!?5,"PGx eligible drugs on the profile:",!
D AL
S PSSPPRF1="" F S PSSPPRF1=$O(PSSLOCZZ(PSSPPRF1)) Q:PSSPPRF1=""!($G(PSSPGXQT)) D
.S PSSPPRFP=PSSLOCZZ(PSSPPRF1) S PSSPPRFC=0 F PSSPPRFA=1:1:$L(PSSPPRFP) I $E(PSSPPRFP,PSSPPRFA)="^" S PSSPPRFC=PSSPPRFC+1
.S PSSPPRFC=PSSPPRFC+1
.S PSSPPRFZ="("
.F PSSPPRFL=2:1:PSSPPRFC S PSSPPRFZ=PSSPPRFZ_$S(PSSPPRFL>2:", ",1:"")_$P(PSSPPRFP,"^",PSSPPRFL)
.S PSSPPRFZ=PSSPPRFZ_")"
.W !,PSSPPRF1_" "_PSSPPRFZ
.D PAUSE4^PSSPGXTS
K PSSLOCZZ
S PSSASKQT=0
S DIR(0)="Y",DIR("?")=" ",DIR("?",1)="Enter 'YES' to add additional drugs to the current profile list,"
S DIR("?",2)="enter 'NO' to use only the profile list for the drug input."
S DIR("A")="Do you want to add drugs to the list above",DIR("B")="Y"
W ! D ^DIR K DIR I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSSASKQT=1 Q
S PSSNOADD=$S(Y:0,1:1)
Q
;
CHECK ;
N PSSPXPDX,PSSPXPDA,PSSPXPDC,PSSPXPDW,PSSPXPDN,PSSPXPGC,PSSPXPPK,PSSPXPNM,PSSPXPVP,PSSPXPOD,PSSTMPNM
S PSSPXPDX="" F S PSSPXPDX=$O(^TMP($J,"ORDERS",PSSPXPDX)) Q:PSSPXPDX="" D
.S PSSPXPDA=$G(^TMP($J,"ORDERS",PSSPXPDX))
.S PSSPXPPK=$P(PSSPXPDA,"^",5),PSSPXPNM=$P(PSSPXPDA,"^",3)
.S PSSPXPPK=$S(PSSPXPPK["U;I":"UD",PSSPXPPK["P;I":"Pending Inp.",PSSPXPPK["V;I":"IV",PSSPXPPK["P;O":"Pending Out.",PSSPXPPK["R;O":"Rx",PSSPXPPK["X;O":"Non-VA",1:"")
.S PSSPXPDC=$P(PSSPXPDA,"^",2),PSSPXPDW=$P(PSSPXPDC,"A"),PSSPXPDN=$P(PSSPXPDC,"A",2) I 'PSSPXPDN!('PSSPXPDW) Q
.I '$P($$PGX^PSNAPIS(PSSPXPDX,PSSPXPDN),"^") Q
.S PSSPXPOD=$$PROD0^PSNAPIS(PSSPXPDX,PSSPXPDN)
.S PSSPXPGC=+$P(PSSPXPOD,"^",7)
.S PSSPXPVP=$P(PSSPXPOD,"^")
.I PSSPXPGC D
..I $D(PSSPGXDG(PSSPXPGC,"GCN")) D S PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM)=$S(PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM)[PSSPXPPK:PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM),1:$G(PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM))_"^"_PSSPXPPK) Q
...S PSSTMPNM=$O(PSSLOCNM(PSSPXPGC,"LOCNAME",""))
..S PSSPGXDG(PSSPXPGC,"GCN")=PSSPXPGC
..S PSSPGXVA(PSSPXPGC,"VAPROD")=PSSPXPVP
..S PSSPGXDG(PSSPXPGC,"DRUGNAME")=$G(PSSPXPNM)
..S PSSPGXDG(PSSPXPGC,"VUID")=$$GETVUID^XTID(50.68,,PSSPXPDN_",")
..S PSSLOCNM(PSSPXPGC,"LOCNAME",PSSPXPNM)="^"_PSSPXPPK
K ^TMP($J,"ORDERS")
Q
;
;
DISP ;
N PSSPXL,PSSPTLAB,PSSGTBL,PSSGDT,PSSOUT,RETURN,PSSURL,PSSTXT
S PSSOUT=$$GETPGXRESULTS^PSSHDPG1(PSSTESTP,.PSSPTLAB)
I +PSSOUT=-1 W !!,"Pharmacogenomic Lab Data could not be retrieved at this time.",! D PAUSE2^PSSPGXTS Q
D PTLAB^PSSPGX(.PSSPTLAB)
D GENETBL^PSSPGX(.PSSGDT)
I '$D(PSSGTBL) W !!,"Patient has no pharmacogenomic lab results.",! D PAUSE2^PSSPGXTS Q
F PSSPXL=0:0 S PSSPXL=$O(PSSGTBL(PSSPXL)) Q:'PSSPXL!($G(PSSASKQT)) D
.W !,PSSGTBL(PSSPXL) D PAUSE
I '$G(PSSASKQT) W !!,"End of Gene list." D PAUSE2^PSSPGXTS
S PSSASKQT=0
Q
PAUSE ;
I ($Y+5)'>IOSL Q
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit list" D ^DIR K DIR I 'Y S PSSASKQT=1
W @IOF
Q
;
CONV ;Convert PSSGENES array to PSSGENE array
N PSSCVX K PSSGENE
S PSSCVX="" F S PSSCVX=$O(PSSGENES(PSSCVX)) Q:PSSCVX="" D
.S PSSGENE(PSSCVX,"GENE")=""
.S PSSGENE(PSSCVX,"ACTIVITY_SCORE")=$G(PSSGENES(PSSCVX,"ACTIVITY_SCORE"))
.S PSSGENE(PSSCVX,"GENOTYPE")=$G(PSSGENES(PSSCVX,"GENOTYPE"))
.S PSSGENE(PSSCVX,"PHENOTYPE")=$G(PSSGENES(PSSCVX,"PHENOTYPE"))
Q
;
ACTSCR() ;Activity Score selection
PASS ;
K DIR S PSSSCORE="",DIR("?")=" "
S DIR("?",1)=" Enter the Activity Score, 1 to 30 characters. This can be a whole number,"
S DIR("?",2)=" or a number with a decimal."
S DIR(0)="FO^1:40",DIR("A")="Enter "_PSSGLP_" Activity Score"
W ! D ^DIR I X=""!($D(DIRUT)) K X,DIR Q ""
S X=$$UP^XLFSTR(X)
I (X'?.N)&(X'?.N1".".N) W !!,"Invalid Activity Score." D PAUSE2^PSSPGXTS K X G PASS
S PSSSCORE=X
Q PSSSCORE
;
INTRO ;Show PGx eligible drugs
N PSSINTRA,PSSINTRB,PSSINRC,DIR,X,Y,DTOUT,DUOUT,DIRUT,PSSPGXQL,PSSINTRC
W !!," Drug selection ***Only PGx-eligible drugs are available for selection***",!
K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to see the PGx eligible drugs" D ^DIR I Y'=1 W ! Q
W ! K ^TMP($J,"PSSPGXLS") S PSSPGXQL=0
S PSSINTRA="" F S PSSINTRA=$O(^PSNDF(50.68,"APGX",PSSINTRA)) Q:PSSINTRA="" D
.S PSSINTRB="" F S PSSINTRB=$O(^PSDRUG("APR",PSSINTRA,PSSINTRB)) Q:PSSINTRB="" D
..S ^TMP($J,"PSSPGXLS",$P(^PSDRUG(PSSINTRB,0),"^"))=""
S PSSINTRC="" F S PSSINTRC=$O(^TMP($J,"PSSPGXLS",PSSINTRC)) Q:PSSINTRC=""!(PSSPGXQL) D
.I ($Y+5)>IOSL D PAUSEL^PSSPGXTS
.Q:PSSPGXQL
.W !?5,PSSINTRC
I 'PSSPGXQL K DIR W ! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR
W !
K ^TMP($J,"PSSPGXLS")
Q
;
AL ;Convert drug array to alpha sort PSSLOCZZ
N PSSCALG,PSSCALG1
K PSSLOCZZ
S PSSCALG="" F S PSSCALG=$O(PSSLOCNM(PSSCALG)) Q:PSSCALG="" D
.S PSSCALG1=$O(PSSLOCNM(PSSCALG,"LOCNAME",""))
.;S PSSLOCZZ(PSSCALG1)=""
.S PSSLOCZZ(PSSCALG1)=PSSLOCNM(PSSCALG,"LOCNAME",PSSCALG1)
Q
;
RESET ;reset variables
K DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DLAYGO,PSSLTXT,PSSGENE,PSSVAR1,PSSVAR2,PSSGCT,PSSPGXRS,PSSPGXDC,PSSLOC,PSSLOCNM,PSSVAR4,PSSDRGCT,PSSERRG1,PSSERRG2,PSSERRG3,PSSERRG4,PSSERRG5,PSSERRG6,PSSERRG7,PSSERRGN,PSSERRGL
K PSSPGXQT,PSSPGXDG,PSSPGXND,PSSPPROD,PSSDF1C,PSSGAR,PSSGLP,PSS50IEN,PSSDISPD,PSSDISPG,PSSPGXSV,PSSPGXAR,PSSPHAR,PSSPGXVA,PSSGLPH,PSSFDBFG,PSSOPTFG,PSSGTYPE,PSSLFEED,PSSGLOOP,PSSGVAL,PSSGVALT,PSSPHEN,PSSSCORE,PSSPGEND
K PSSPDRUG,PSSASKQT,PSSTESTP,PSSGENES,PSSPERR,PSSNOADD,PSSLOCZZ,PSSPHDT
S (PSSASKQT,PSSTESTP,PSSPDRUG,PSSGLOOP)=0
S PSSPGEND=1
Q
;
REBUILD ;rebuild TMP global for Outpatient
N PSSWOI1,PSSWOI2,PSSWOI3,PSSWOI4,PSSWOI6,PSSWOI7,PSSWOI8,PSSWOI9,PSSWOIFL,PSSWOIKL,PSSWOIST,PSSWOIDG,PSSWOIND,PSSWOITM
S PSSWOIFL=0
S PSSWOI1="" F S PSSWOI1=$O(^TMP($J,"ORDERS",PSSWOI1)) Q:PSSWOI1="" D
.S PSSWOI2=$G(^TMP($J,"ORDERS",PSSWOI1))
.I $P(PSSWOI2,"^",5)'["P" Q
.S PSSWOI3=+$P(PSSWOI2,"^",5) I 'PSSWOI3 Q
.S PSSWOI4=$G(^PS(52.41,PSSWOI3,0))
.I $P(PSSWOI4,"^",9) Q
.S PSSWOITM=$P(PSSWOI4,"^",8) Q:'PSSWOITM
.S PSSWOIFL=1
.I $D(PSSWOIST(PSSWOITM)) S PSSWOIKL(PSSWOI1)="" Q
.S PSSWOIST(PSSWOITM)=$$BDA^PSSPGXOR(PSSWOITM,"O")
.S PSSWOIKL(PSSWOI1)=""
I 'PSSWOIFL Q
S PSSWOI6="" F S PSSWOI6=$O(PSSWOIKL(PSSWOI6)) Q:PSSWOI6="" K ^TMP($J,"ORDERS",PSSWOI6)
S PSSWOI7="" F S PSSWOI7=$O(^TMP($J,"ORDERS",PSSWOI7)) Q:PSSWOI7="" S PSSWOI8=PSSWOI7
I '$G(PSSWOI8) S PSSWOI8=0
S PSSWOI8=PSSWOI8+1
S PSSWOI9="" F S PSSWOI9=$O(PSSWOIST(PSSWOI9)) Q:PSSWOI9="" S PSSWOIDG=+PSSWOIST(PSSWOI9) I PSSWOIDG D
.S PSSWOIND=$G(^PSDRUG(PSSWOIDG,"ND"))
.S ^TMP($J,"ORDERS",PSSWOI8)="^"_$P(PSSWOIND,"^")_"A"_$P(PSSWOIND,"^",3)_"^"_$P($G(^PSDRUG(PSSWOIDG,0)),"^")_"^^"_PSSWOI8_"P;O"
.S PSSWOI8=PSSWOI8+1
Q
;
REBUILDI ;rebuild TMP global for Inpatient
N PSSBOI1,PSSBOI2,PSSBOI3,PSSBOI6,PSSBOI7,PSSBOI8,PSSBOI9,PSSBOIFL,PSSBOIKL,PSSBOITM,PSSBOIND,PSSBOIDG,PSSBOIST
S PSSBOIFL=0
S PSSBOI1="" F S PSSBOI1=$O(^TMP($J,"ORDERS",PSSBOI1)) Q:PSSBOI1="" D
.S PSSBOI2=$G(^TMP($J,"ORDERS",PSSBOI1))
.I $P(PSSBOI2,"^",5)'["P;I" Q
.S PSSBOI3=+$P(PSSBOI2,"^",5) I 'PSSBOI3 Q
.I $P($G(^PS(53.1,PSSBOI3,0)),"^",4)'="U" Q
.I $O(^PS(53.1,PSSBOI3,1,0)) Q
.S PSSBOITM=$P($G(^PS(53.1,PSSBOI3,.2)),"^") Q:'PSSBOITM
.S PSSBOIFL=1
.I $D(PSSBOIST(PSSBOITM)) S PSSBOIKL(PSSBOI1)="" Q
.S PSSBOIST(PSSBOITM)=$$BDA^PSSPGXOR(PSSBOITM,"U")
.S PSSBOIKL(PSSBOI1)=""
I 'PSSBOIFL Q
S PSSBOI6="" F S PSSBOI6=$O(PSSBOIKL(PSSBOI6)) Q:PSSBOI6="" K ^TMP($J,"ORDERS",PSSBOI6)
S PSSBOI7="" F S PSSBOI7=$O(^TMP($J,"ORDERS",PSSBOI7)) Q:PSSBOI7="" S PSSBOI8=PSSBOI7
I '$G(PSSBOI8) S PSSBOI8=0
S PSSBOI8=PSSBOI8+1
S PSSBOI9="" F S PSSBOI9=$O(PSSBOIST(PSSBOI9)) Q:PSSBOI9="" S PSSBOIDG=+PSSBOIST(PSSBOI9) I PSSBOIDG D
.S PSSBOIND=$G(^PSDRUG(PSSBOIDG,"ND"))
.S ^TMP($J,"ORDERS",PSSBOI8)="^"_$P(PSSBOIND,"^")_"A"_$P(PSSBOIND,"^",3)_"^"_$P($G(^PSDRUG(PSSBOIDG,0)),"^")_"^^"_PSSBOI8_"P;I"
.S PSSBOI8=PSSBOI8+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPGXT1 10061 printed Mar 25, 2026@15:58:15 Page 2
PSSPGXT1 ;BIR/RTR - PHARMACOGENOMICS TEST OPTION CONTINUED;09/20/07
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**262**;9/30/97;Build 66
+2 ;
+3 ;Reference to BLD^PSOOCPGX is supported by ICR #7527
+4 ;Reference to EHCHK^PSJORUT2 is supported by ICR #2376
+5 ;
ASK() ;
+1 NEW DIR,DUOUT,DIRUT,DTOUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("?")=" "
SET DIR("?",1)="Enter 'YES' to use a patients genomic lab data for the input,"
+3 SET DIR("?",2)="enter 'NO' to select genomic data for the input."
+4 SET DIR("A")="Do you want to use a specific patient"
SET DIR("B")="Y"
+5 DO ^DIR
KILL DIR
IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
SET PSSASKQT=1
QUIT 0
+6 QUIT Y
+7 ;
ASKPT ;
+1 NEW DIR,DUOUT,DIRUT,DTOUT,X,Y
+2 WRITE !
SET DIC=2
SET DIC(0)="QEAM"
DO ^DIC
IF Y'>0!($DATA(DUOUT))!($DATA(DTOUT))
QUIT
+3 SET PSSTESTP=+Y
+4 QUIT
+5 ;
ASKDR ;
+1 NEW DIR,DUOUT,DIRUT,DTOUT,X,Y,PSSNVAL,PSSNVA0,PSSNVAC,PSSNVACP,PSSNVADG,PSSPPRF,PSSPPRF1,PSSPPRFP,PSSPPRFC,PSSPPRFA,PSSPPRFL,PSSPPRFZ
+2 SET DIR(0)="Y"
SET DIR("?")=" "
SET DIR("?",1)="Enter 'YES' to use the patients PGX eligible active drugs as prospective drugs,"
+3 SET DIR("?",2)="enter 'NO' to select prospective drugs."
+4 SET DIR("A",1)="Do you want to use the patient's pharmacogenomic eligible drug(s)"
SET DIR("A")="from their medication profile(s)"
SET DIR("B")="Y"
+5 DO ^DIR
KILL DIR
IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
SET PSSASKQT=1
QUIT
+6 SET PSSPDRUG=Y
+7 IF 'PSSPDRUG
QUIT
+8 KILL ^TMP($JOB,"ORDERS")
DO ENCHK^PSJORUT2(PSSTESTP,0)
IF $DATA(^TMP($JOB,"ORDERS"))
DO REBUILDI
DO CHECK
+9 DO BLD^PSOOCPGX(PSSTESTP,90)
IF $DATA(^TMP($JOB,"ORDERS"))
DO REBUILD
DO CHECK
+10 SET PSSNVAC=1
+11 SET PSSNVAL=""
FOR
SET PSSNVAL=$ORDER(^PS(55,PSSTESTP,"NVA",PSSNVAL))
if PSSNVAL=""
QUIT
Begin DoDot:1
+12 SET PSSNVA0=$GET(^PS(55,PSSTESTP,"NVA",PSSNVAL,0))
+13 IF $PIECE(PSSNVA0,"^",6)
QUIT
+14 IF $PIECE(PSSNVA0,"^",7)
IF $PIECE(PSSNVA0,"^",7)<DT
QUIT
+15 IF '$PIECE(PSSNVA0,"^")
IF '$PIECE(PSSNVA0,"^",2)
QUIT
+16 SET PSSNVADG=$PIECE(PSSNVA0,"^",2)
+17 IF 'PSSNVADG
SET PSSNVADG=+$$BDA^PSSPGXOR($PIECE(PSSNVA0,"^"),"X")
+18 IF 'PSSNVADG
QUIT
+19 SET PSSNVACP=$GET(^PSDRUG(PSSNVADG,"ND"))
+20 SET ^TMP($JOB,"ORDERS",PSSNVAC)="^"_$PIECE(PSSNVACP,"^")_"A"_$PIECE(PSSNVACP,"^",3)_"^"_$PIECE($GET(^PSDRUG(PSSNVADG,0)),"^")_"^^"_PSSNVAC_"X;O"
+21 SET PSSNVAC=PSSNVAC+1
End DoDot:1
+22 IF $DATA(^TMP($JOB,"ORDERS"))
DO CHECK
+23 WRITE @IOF
+24 IF '$DATA(PSSPGXDG)
WRITE !,"Patient does not have any pharmacogenomic eligible drugs",!,"on their medication profile.",!
DO PAUSE2^PSSPGXTS
QUIT
+25 WRITE !!?5,"PGx eligible drugs on the profile:",!
+26 DO AL
+27 SET PSSPPRF1=""
FOR
SET PSSPPRF1=$ORDER(PSSLOCZZ(PSSPPRF1))
if PSSPPRF1=""!($GET(PSSPGXQT))
QUIT
Begin DoDot:1
+28 SET PSSPPRFP=PSSLOCZZ(PSSPPRF1)
SET PSSPPRFC=0
FOR PSSPPRFA=1:1:$LENGTH(PSSPPRFP)
IF $EXTRACT(PSSPPRFP,PSSPPRFA)="^"
SET PSSPPRFC=PSSPPRFC+1
+29 SET PSSPPRFC=PSSPPRFC+1
+30 SET PSSPPRFZ="("
+31 FOR PSSPPRFL=2:1:PSSPPRFC
SET PSSPPRFZ=PSSPPRFZ_$SELECT(PSSPPRFL>2:", ",1:"")_$PIECE(PSSPPRFP,"^",PSSPPRFL)
+32 SET PSSPPRFZ=PSSPPRFZ_")"
+33 WRITE !,PSSPPRF1_" "_PSSPPRFZ
+34 DO PAUSE4^PSSPGXTS
End DoDot:1
+35 KILL PSSLOCZZ
+36 SET PSSASKQT=0
+37 SET DIR(0)="Y"
SET DIR("?")=" "
SET DIR("?",1)="Enter 'YES' to add additional drugs to the current profile list,"
+38 SET DIR("?",2)="enter 'NO' to use only the profile list for the drug input."
+39 SET DIR("A")="Do you want to add drugs to the list above"
SET DIR("B")="Y"
+40 WRITE !
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
SET PSSASKQT=1
QUIT
+41 SET PSSNOADD=$SELECT(Y:0,1:1)
+42 QUIT
+43 ;
CHECK ;
+1 NEW PSSPXPDX,PSSPXPDA,PSSPXPDC,PSSPXPDW,PSSPXPDN,PSSPXPGC,PSSPXPPK,PSSPXPNM,PSSPXPVP,PSSPXPOD,PSSTMPNM
+2 SET PSSPXPDX=""
FOR
SET PSSPXPDX=$ORDER(^TMP($JOB,"ORDERS",PSSPXPDX))
if PSSPXPDX=""
QUIT
Begin DoDot:1
+3 SET PSSPXPDA=$GET(^TMP($JOB,"ORDERS",PSSPXPDX))
+4 SET PSSPXPPK=$PIECE(PSSPXPDA,"^",5)
SET PSSPXPNM=$PIECE(PSSPXPDA,"^",3)
+5 SET PSSPXPPK=$SELECT(PSSPXPPK["U;I":"UD",PSSPXPPK["P;I":"Pending Inp.",PSSPXPPK["V;I":"IV",PSSPXPPK["P;O":"Pending Out.",PSSPXPPK["R;O":"Rx",PSSPXPPK["X;O":"Non-VA",1:"")
+6 SET PSSPXPDC=$PIECE(PSSPXPDA,"^",2)
SET PSSPXPDW=$PIECE(PSSPXPDC,"A")
SET PSSPXPDN=$PIECE(PSSPXPDC,"A",2)
IF 'PSSPXPDN!('PSSPXPDW)
QUIT
+7 IF '$PIECE($$PGX^PSNAPIS(PSSPXPDX,PSSPXPDN),"^")
QUIT
+8 SET PSSPXPOD=$$PROD0^PSNAPIS(PSSPXPDX,PSSPXPDN)
+9 SET PSSPXPGC=+$PIECE(PSSPXPOD,"^",7)
+10 SET PSSPXPVP=$PIECE(PSSPXPOD,"^")
+11 IF PSSPXPGC
Begin DoDot:2
+12 IF $DATA(PSSPGXDG(PSSPXPGC,"GCN"))
Begin DoDot:3
+13 SET PSSTMPNM=$ORDER(PSSLOCNM(PSSPXPGC,"LOCNAME",""))
End DoDot:3
SET PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM)=$SELECT(PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM)[PSSPXPPK:PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM),1:$GET(PSSLOCNM(PSSPXPGC,"LOCNAME",PSSTMPNM))_"^"_PSSPXPPK)
QUIT
+14 SET PSSPGXDG(PSSPXPGC,"GCN")=PSSPXPGC
+15 SET PSSPGXVA(PSSPXPGC,"VAPROD")=PSSPXPVP
+16 SET PSSPGXDG(PSSPXPGC,"DRUGNAME")=$GET(PSSPXPNM)
+17 SET PSSPGXDG(PSSPXPGC,"VUID")=$$GETVUID^XTID(50.68,,PSSPXPDN_",")
+18 SET PSSLOCNM(PSSPXPGC,"LOCNAME",PSSPXPNM)="^"_PSSPXPPK
End DoDot:2
End DoDot:1
+19 KILL ^TMP($JOB,"ORDERS")
+20 QUIT
+21 ;
+22 ;
DISP ;
+1 NEW PSSPXL,PSSPTLAB,PSSGTBL,PSSGDT,PSSOUT,RETURN,PSSURL,PSSTXT
+2 SET PSSOUT=$$GETPGXRESULTS^PSSHDPG1(PSSTESTP,.PSSPTLAB)
+3 IF +PSSOUT=-1
WRITE !!,"Pharmacogenomic Lab Data could not be retrieved at this time.",!
DO PAUSE2^PSSPGXTS
QUIT
+4 DO PTLAB^PSSPGX(.PSSPTLAB)
+5 DO GENETBL^PSSPGX(.PSSGDT)
+6 IF '$DATA(PSSGTBL)
WRITE !!,"Patient has no pharmacogenomic lab results.",!
DO PAUSE2^PSSPGXTS
QUIT
+7 FOR PSSPXL=0:0
SET PSSPXL=$ORDER(PSSGTBL(PSSPXL))
if 'PSSPXL!($GET(PSSASKQT))
QUIT
Begin DoDot:1
+8 WRITE !,PSSGTBL(PSSPXL)
DO PAUSE
End DoDot:1
+9 IF '$GET(PSSASKQT)
WRITE !!,"End of Gene list."
DO PAUSE2^PSSPGXTS
+10 SET PSSASKQT=0
+11 QUIT
PAUSE ;
+1 IF ($Y+5)'>IOSL
QUIT
+2 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit list"
DO ^DIR
KILL DIR
IF 'Y
SET PSSASKQT=1
+3 WRITE @IOF
+4 QUIT
+5 ;
CONV ;Convert PSSGENES array to PSSGENE array
+1 NEW PSSCVX
KILL PSSGENE
+2 SET PSSCVX=""
FOR
SET PSSCVX=$ORDER(PSSGENES(PSSCVX))
if PSSCVX=""
QUIT
Begin DoDot:1
+3 SET PSSGENE(PSSCVX,"GENE")=""
+4 SET PSSGENE(PSSCVX,"ACTIVITY_SCORE")=$GET(PSSGENES(PSSCVX,"ACTIVITY_SCORE"))
+5 SET PSSGENE(PSSCVX,"GENOTYPE")=$GET(PSSGENES(PSSCVX,"GENOTYPE"))
+6 SET PSSGENE(PSSCVX,"PHENOTYPE")=$GET(PSSGENES(PSSCVX,"PHENOTYPE"))
End DoDot:1
+7 QUIT
+8 ;
ACTSCR() ;Activity Score selection
PASS ;
+1 KILL DIR
SET PSSSCORE=""
SET DIR("?")=" "
+2 SET DIR("?",1)=" Enter the Activity Score, 1 to 30 characters. This can be a whole number,"
+3 SET DIR("?",2)=" or a number with a decimal."
+4 SET DIR(0)="FO^1:40"
SET DIR("A")="Enter "_PSSGLP_" Activity Score"
+5 WRITE !
DO ^DIR
IF X=""!($DATA(DIRUT))
KILL X,DIR
QUIT ""
+6 SET X=$$UP^XLFSTR(X)
+7 IF (X'?.N)&(X'?.N1".".N)
WRITE !!,"Invalid Activity Score."
DO PAUSE2^PSSPGXTS
KILL X
GOTO PASS
+8 SET PSSSCORE=X
+9 QUIT PSSSCORE
+10 ;
INTRO ;Show PGx eligible drugs
+1 NEW PSSINTRA,PSSINTRB,PSSINRC,DIR,X,Y,DTOUT,DUOUT,DIRUT,PSSPGXQL,PSSINTRC
+2 WRITE !!," Drug selection ***Only PGx-eligible drugs are available for selection***",!
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to see the PGx eligible drugs"
DO ^DIR
IF Y'=1
WRITE !
QUIT
+4 WRITE !
KILL ^TMP($JOB,"PSSPGXLS")
SET PSSPGXQL=0
+5 SET PSSINTRA=""
FOR
SET PSSINTRA=$ORDER(^PSNDF(50.68,"APGX",PSSINTRA))
if PSSINTRA=""
QUIT
Begin DoDot:1
+6 SET PSSINTRB=""
FOR
SET PSSINTRB=$ORDER(^PSDRUG("APR",PSSINTRA,PSSINTRB))
if PSSINTRB=""
QUIT
Begin DoDot:2
+7 SET ^TMP($JOB,"PSSPGXLS",$PIECE(^PSDRUG(PSSINTRB,0),"^"))=""
End DoDot:2
End DoDot:1
+8 SET PSSINTRC=""
FOR
SET PSSINTRC=$ORDER(^TMP($JOB,"PSSPGXLS",PSSINTRC))
if PSSINTRC=""!(PSSPGXQL)
QUIT
Begin DoDot:1
+9 IF ($Y+5)>IOSL
DO PAUSEL^PSSPGXTS
+10 if PSSPGXQL
QUIT
+11 WRITE !?5,PSSINTRC
End DoDot:1
+12 IF 'PSSPGXQL
KILL DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
+13 WRITE !
+14 KILL ^TMP($JOB,"PSSPGXLS")
+15 QUIT
+16 ;
AL ;Convert drug array to alpha sort PSSLOCZZ
+1 NEW PSSCALG,PSSCALG1
+2 KILL PSSLOCZZ
+3 SET PSSCALG=""
FOR
SET PSSCALG=$ORDER(PSSLOCNM(PSSCALG))
if PSSCALG=""
QUIT
Begin DoDot:1
+4 SET PSSCALG1=$ORDER(PSSLOCNM(PSSCALG,"LOCNAME",""))
+5 ;S PSSLOCZZ(PSSCALG1)=""
+6 SET PSSLOCZZ(PSSCALG1)=PSSLOCNM(PSSCALG,"LOCNAME",PSSCALG1)
End DoDot:1
+7 QUIT
+8 ;
RESET ;reset variables
+1 KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DLAYGO,PSSLTXT,PSSGENE,PSSVAR1,PSSVAR2,PSSGCT,PSSPGXRS,PSSPGXDC,PSSLOC,PSSLOCNM,PSSVAR4,PSSDRGCT,PSSERRG1,PSSERRG2,PSSERRG3,PSSERRG4,PSSERRG5,PSSERRG6,PSSERRG7,PSSERRGN,PSSERRGL
+2 KILL PSSPGXQT,PSSPGXDG,PSSPGXND,PSSPPROD,PSSDF1C,PSSGAR,PSSGLP,PSS50IEN,PSSDISPD,PSSDISPG,PSSPGXSV,PSSPGXAR,PSSPHAR,PSSPGXVA,PSSGLPH,PSSFDBFG,PSSOPTFG,PSSGTYPE,PSSLFEED,PSSGLOOP,PSSGVAL,PSSGVALT,PSSPHEN,PSSSCORE,PSSPGEND
+3 KILL PSSPDRUG,PSSASKQT,PSSTESTP,PSSGENES,PSSPERR,PSSNOADD,PSSLOCZZ,PSSPHDT
+4 SET (PSSASKQT,PSSTESTP,PSSPDRUG,PSSGLOOP)=0
+5 SET PSSPGEND=1
+6 QUIT
+7 ;
REBUILD ;rebuild TMP global for Outpatient
+1 NEW PSSWOI1,PSSWOI2,PSSWOI3,PSSWOI4,PSSWOI6,PSSWOI7,PSSWOI8,PSSWOI9,PSSWOIFL,PSSWOIKL,PSSWOIST,PSSWOIDG,PSSWOIND,PSSWOITM
+2 SET PSSWOIFL=0
+3 SET PSSWOI1=""
FOR
SET PSSWOI1=$ORDER(^TMP($JOB,"ORDERS",PSSWOI1))
if PSSWOI1=""
QUIT
Begin DoDot:1
+4 SET PSSWOI2=$GET(^TMP($JOB,"ORDERS",PSSWOI1))
+5 IF $PIECE(PSSWOI2,"^",5)'["P"
QUIT
+6 SET PSSWOI3=+$PIECE(PSSWOI2,"^",5)
IF 'PSSWOI3
QUIT
+7 SET PSSWOI4=$GET(^PS(52.41,PSSWOI3,0))
+8 IF $PIECE(PSSWOI4,"^",9)
QUIT
+9 SET PSSWOITM=$PIECE(PSSWOI4,"^",8)
if 'PSSWOITM
QUIT
+10 SET PSSWOIFL=1
+11 IF $DATA(PSSWOIST(PSSWOITM))
SET PSSWOIKL(PSSWOI1)=""
QUIT
+12 SET PSSWOIST(PSSWOITM)=$$BDA^PSSPGXOR(PSSWOITM,"O")
+13 SET PSSWOIKL(PSSWOI1)=""
End DoDot:1
+14 IF 'PSSWOIFL
QUIT
+15 SET PSSWOI6=""
FOR
SET PSSWOI6=$ORDER(PSSWOIKL(PSSWOI6))
if PSSWOI6=""
QUIT
KILL ^TMP($JOB,"ORDERS",PSSWOI6)
+16 SET PSSWOI7=""
FOR
SET PSSWOI7=$ORDER(^TMP($JOB,"ORDERS",PSSWOI7))
if PSSWOI7=""
QUIT
SET PSSWOI8=PSSWOI7
+17 IF '$GET(PSSWOI8)
SET PSSWOI8=0
+18 SET PSSWOI8=PSSWOI8+1
+19 SET PSSWOI9=""
FOR
SET PSSWOI9=$ORDER(PSSWOIST(PSSWOI9))
if PSSWOI9=""
QUIT
SET PSSWOIDG=+PSSWOIST(PSSWOI9)
IF PSSWOIDG
Begin DoDot:1
+20 SET PSSWOIND=$GET(^PSDRUG(PSSWOIDG,"ND"))
+21 SET ^TMP($JOB,"ORDERS",PSSWOI8)="^"_$PIECE(PSSWOIND,"^")_"A"_$PIECE(PSSWOIND,"^",3)_"^"_$PIECE($GET(^PSDRUG(PSSWOIDG,0)),"^")_"^^"_PSSWOI8_"P;O"
+22 SET PSSWOI8=PSSWOI8+1
End DoDot:1
+23 QUIT
+24 ;
REBUILDI ;rebuild TMP global for Inpatient
+1 NEW PSSBOI1,PSSBOI2,PSSBOI3,PSSBOI6,PSSBOI7,PSSBOI8,PSSBOI9,PSSBOIFL,PSSBOIKL,PSSBOITM,PSSBOIND,PSSBOIDG,PSSBOIST
+2 SET PSSBOIFL=0
+3 SET PSSBOI1=""
FOR
SET PSSBOI1=$ORDER(^TMP($JOB,"ORDERS",PSSBOI1))
if PSSBOI1=""
QUIT
Begin DoDot:1
+4 SET PSSBOI2=$GET(^TMP($JOB,"ORDERS",PSSBOI1))
+5 IF $PIECE(PSSBOI2,"^",5)'["P;I"
QUIT
+6 SET PSSBOI3=+$PIECE(PSSBOI2,"^",5)
IF 'PSSBOI3
QUIT
+7 IF $PIECE($GET(^PS(53.1,PSSBOI3,0)),"^",4)'="U"
QUIT
+8 IF $ORDER(^PS(53.1,PSSBOI3,1,0))
QUIT
+9 SET PSSBOITM=$PIECE($GET(^PS(53.1,PSSBOI3,.2)),"^")
if 'PSSBOITM
QUIT
+10 SET PSSBOIFL=1
+11 IF $DATA(PSSBOIST(PSSBOITM))
SET PSSBOIKL(PSSBOI1)=""
QUIT
+12 SET PSSBOIST(PSSBOITM)=$$BDA^PSSPGXOR(PSSBOITM,"U")
+13 SET PSSBOIKL(PSSBOI1)=""
End DoDot:1
+14 IF 'PSSBOIFL
QUIT
+15 SET PSSBOI6=""
FOR
SET PSSBOI6=$ORDER(PSSBOIKL(PSSBOI6))
if PSSBOI6=""
QUIT
KILL ^TMP($JOB,"ORDERS",PSSBOI6)
+16 SET PSSBOI7=""
FOR
SET PSSBOI7=$ORDER(^TMP($JOB,"ORDERS",PSSBOI7))
if PSSBOI7=""
QUIT
SET PSSBOI8=PSSBOI7
+17 IF '$GET(PSSBOI8)
SET PSSBOI8=0
+18 SET PSSBOI8=PSSBOI8+1
+19 SET PSSBOI9=""
FOR
SET PSSBOI9=$ORDER(PSSBOIST(PSSBOI9))
if PSSBOI9=""
QUIT
SET PSSBOIDG=+PSSBOIST(PSSBOI9)
IF PSSBOIDG
Begin DoDot:1
+20 SET PSSBOIND=$GET(^PSDRUG(PSSBOIDG,"ND"))
+21 SET ^TMP($JOB,"ORDERS",PSSBOI8)="^"_$PIECE(PSSBOIND,"^")_"A"_$PIECE(PSSBOIND,"^",3)_"^"_$PIECE($GET(^PSDRUG(PSSBOIDG,0)),"^")_"^^"_PSSBOI8_"P;I"
+22 SET PSSBOI8=PSSBOI8+1
End DoDot:1
+23 QUIT
