APSQDGDG ;IHS/ASDS/ENM/POC - DRUG/DRUG INTERACTION CHECKER
;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
;;6.0;OUTPATIENT PHARMACY;**1,52,118,128,131**;09/03/97
;NOTE: THIS ROUTINE IS A MODIFIED COPY OF THE ORIGINAL VA PSODGDG
S EN="INVEN" D ^APSQSHOW
D EN^APSQDGDG
K AZOSD
Q
EN ;CHANGED PSOSD TO AZOSD IHS/OKCAO/POC
;W !,"Checking for Drug/Drug Interactions !",!
;IF '(PSODRUG("NDF")?1.N1"A"1.N),PSODRUG("DEA")'["S" W !,*7,*7,$S(PSODRUG("NAME")="OUTSIDE DRUG":"THIS DRUG",1:PSODRUG("NAME"))," CANNOT BE CHECKED FOR INTERACTIONS. IT HAS NO ENTRY IN NATIONAL DRUG FILE!!" ;WARN OF NO NDF IHS/OKCAO/POC 12/20/97
Q:'(PSODRUG("NDF")?1.N1"A"1.N) ;STOP SINCE CANT CHECK IHS/OKCAO/POC
;S (CRIT,DRG,LSI,DGI,DGS,SER,SERS)="" F S DRG=$O(AZOSD(DRG)) Q:(DRG="")!($G(PSORX("DFLG"))) I $P(AZOSD(DRG),"^",2)<10 D ;ADDED THE Q:$G WHEN STOP AT CRITICAL AND DELETE DRUG SO WONT LOOP THRU OTHER INTERACTIONS IHS/OKCAO/POC 12/3/97
S (CRIT,DRG,LSI,DGI,DGS,SER,SERS)="" F S DRG=$O(AZOSD(DRG)) Q:(DRG="")!($G(PSORX("DFLG"))) D ;ADDED THE Q:$G WHEN STOP AT CRITICAL AND DELETE DRUG SO WONT LOOP THRU OTHER INTERACTIONS IHS/OKCAO/POC 12/3/97 GOT RID OF I ... <10
.;S NDF=$P(AZOSD(DRG),"^",7),IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG"))
.;S NDF=$P(AZOSD(DRG),"^",7) W:'(NDF?1.N1"A"1.N) !,*7,*7,DRG," CANNOT BE CHECKED FOR INTERACTIONS WITH ",PSODRUG("NAME"),". ",DRG," HAS NO ENTRY IN NATIONAL DRUG FILE!!" S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG")) ;ADDED FOR EACH DRUG WITH NO NDF ENTRY IHS/OKCAO/POC 12/20/97
.S NDF=$P(AZOSD(DRG),"^",7)
.;S PSOZDEA=$P(^PSDRUG($P(^PSRX($P(AZOSD(DRG),U),0),U,6),0),U,3)
.S PSOZDEA=$P(^PSDRUG(ARRDRIEN,0),U,3) ;SINCE NO ENTRY IN PSRX FILE
.I '(NDF?1.N1"A"1.N),PSOZDEA'["S" W !!,*7,*7,DRG," CANNOT BE CHECKED FOR INTERACTIONS WITH ",PSODRUG("NAME"),". ",DRG," HAS NO ENTRY IN NATIONAL DRUG FILE!!",! ;DONT LOOK AT SUPPLY ITEMS
.S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG")) ;ADDED FOR EACH DRUG WITH NO NDF ENTRY IHS/OKCAO/POC 12/20/97
I '$D(^XUSEC("PSORPH",DUZ)),$G(DGI)]"" S:+CRIT PSONEW("STATUS")=4 W *7,!,"DRUG INTERACTON WITH RX #s: "_LSI,! K LSI,DRG,IT,NDF
Q
TECH ;add tech entry to RX VERIFY file (#52.4)
I +CRIT S PSODI=1,(DIC,DLAYGO)="^PS(52.4,",DIC(0)="L",(DINUM,X)=PSOX("IRXN"),DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4///"_DT_";7///"_1_";7.1///"_SER_";7.2///"_DGI K DD,DO D FILE^DICN
S:$G(DGS)'="" $P(^PSRX(PSOX("IRXN"),"DRI"),"^")=SERS,$P(^PSRX(PSOX("IRXN"),"DRI"),"^",2)=DGS K PSODI,CRIT,DIC,DLAYGO,DINUM,DGI,DGS,SER,SERS Q
BLD I $D(^XUSEC("PSORPH",DUZ)) S PSORX("PHARM")=DUZ D PHARM Q
;S LSI=$P(^PSRX(+AZOSD(DRG),0),"^")_"/"_$P(^PSDRUG($P(^(0),"^",6),0),"^")_","_LSI,DGI=$P(AZOSD(DRG),"^")_","_DGI,SER=IT_","_SER I $P(AZOSD(DRG),"^",9),$P(^PS(56,IT,0),"^",4)=1 S $P(^PSRX(+AZOSD(DRG),0),"^",15)=4
S LSI="--"_"/"_$P(^PSDRUG(ARRDRIEN,0),"^")_","_LSI,DGI=""_","_DGI,SER=IT_","_SER
S:$P(^PS(56,IT,0),"^",4)=1 CRIT=1 Q
PHARM ;pharmacist verification of drug interaction
S SER=^PS(56,IT,0),DIR("?",1)="Answer 'YES' if you DO want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
S DIR("?")=" 'NO' if you DON'T want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
W *7,*7 S DIR("A",1)="***"_$S($P(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with DRUG "_DRG
S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to "_$S($P(SER,"^",4)=1:"Continue? ",1:"Intervene? "),DIR("B")="N" D ^DIR
I 'Y,$P(SER,"^",4)=1 S PSORX("DFLG")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT
I Y,$P(SER,"^",4)=1 S PSORX("INTERVENE")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT G CRI Q
I 'Y,$P(SER,"^",4)=2 K DIR,DTOUT,DIRUT,DIROUT,DUOUT Q
I Y,$P(SER,"^",4)=2 S PSORX("INTERVENE")=2,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT D ^PSORXI K PSORX("INTERVENE") ;ADDED IHS/OKCAO/POC 12/3/97
Q
CRI ;process new drug interactions entered by pharmacist
;K DIR G:$P(AZOSD(DRG),"^",9) CRITN S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P"
K DIR S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P" ;ALWAYS DO AN INTERVENTION IHS/OKCAO/POC 11/19/97
S DIR("?",1)="Enter '1' or 'P' to Activate medication",DIR("?")=" '0' or 'A' to Abort Order Entry process" D ^DIR K X1,DIR I 'Y S PSORX("DFLG")=1,DGI="" K DTOUT,DIRUT,DIROUT,DUOUT,PSORX("INTERVENE") Q
I $P(SER,"^",4)=1 D
.D SIG^XUSESIG I X1="" K PSORX("INTERVENE") S PSORX("DFLG")=1 Q
.S PSORX("INTERVENE")=$P(SER,"^",4)
.D ^PSORXI K PSORX("INTERVENE") ;IHS/OKCAO/POC 12/3/97
K DUOUT,DTOUT,DIRUT,DIROUT Q
CRITN ;process multiple new drug interactions
;IT DOESNT WORK ??
K X1,DIR S DIR("A",1)="",DIR("A",2)="Do you want to Delete: ",DIR("A",3)=" 1. NEW medication "_PSODRUG("NAME"),DIR("A",4)=" 2. ACTIVE New Rx #"_$P(^PSRX($P(AZOSD(DRG),"^"),0),"^")_" DRUG: "_DRG
S DIR("A",5)=" 3. Both 1 and 2",DIR("A")=" 4. Continue ?: ",DIR(0)="SA^1:NEW MEDICATION;2:ACTIVE New RX #"_DGI_" "_DRG_";3:BOTH;4:CONTINUE"
S DIR("?",1)="Enter '1' or 'N' to Delete New Medication and Activate RX #"_$P(^PSRX(+AZOSD(DRG),0),"^"),DIR("?",2)=" '2' or 'A' to Delete Active RX #"_$P(^PSRX(+AZOSD(DRG),0),"^")_" and Abort New Order Entry"
S DIR("?",3)=" '3' or 'B' to Delete Both",DIR("?")=" '4' or 'C' to do nothing to either RX" D ^DIR K DIR
I Y=1 S PSORX("DFLG")=1,DGI="",PSHLDDRG=PSODRUG("IEN") S PSODRUG("IEN")=$P(^PSRX($P(AZOSD(DRG),"^"),0),"^",6) D ^PSORXI S PSODRUG("IEN")=PSHLDDRG K DTOUT,DIRUT,DIROUT,DUOUT,PSHLDDRG Q
I Y=2 S (DA,PSOHOLDA)=+AZOSD(DRG) D MESS,ENQ^PSORXDL S DA=PSOHOLDA D EN1^PSORXI(.DA),PPL K AZOSD(DRG),DTOUT,DIROUT,DIRUT,DUOUT,PSOHOLDA S AZOSD=AZOSD-1 Q
I Y=3 S (DA,PSOHOLDA)=+AZOSD(DRG) S AZOSD=AZOSD-1,PSORX("DFLG")=1 D MESS,ENQ^PSORXDL S DA=PSOHOLDA D EN1^PSORXI(.DA),PPL K AZOSD(DRG),PSOHOLDA
K DTOUT,DIROUT,DIRUT,DUOUT
Q
MESS W !!,"Deleting Rx: ",$P($G(^PSRX(DA,0)),"^")," ","Drug: ",$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^"),! Q
PPL F PSOSL=0:0 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL S PSOX2=PSOSL
I $G(PSOX2) D
.F PSOSL=0:1:PSOX2 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL F ENT=1:1:$L(PSORX("PSOL",PSOSL),",") I $P(PSORX("PSOL",PSOSL),",",ENT)=$P(AZOSD(DRG),"^") S PSOL(PSOSL,ENT)=""
.F PSOL=0:0 S PSOL=$O(PSOL(PSOL)) Q:'PSOL F ENT=0:0 S ENT=$O(PSOL(PSOL,ENT)) Q:'ENT D
..I ENT=1,'$P(PSORX("PSOL",PSOL),",",2) K PSORX("PSOL",PSOL) Q
..I ENT=1,$P(PSORX("PSOL",PSOL),",",2) S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",2,99) Q
..S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",1,ENT-1)_","_$P(PSORX("PSOL",PSOL),",",ENT+1,99)
K PSOX2,PSOSL,PSOL,ENT Q
APSQDGDG ;IHS/ASDS/ENM/POC - DRUG/DRUG INTERACTION CHECKER
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
+2 ;;6.0;OUTPATIENT PHARMACY;**1,52,118,128,131**;09/03/97
+3 ;NOTE: THIS ROUTINE IS A MODIFIED COPY OF THE ORIGINAL VA PSODGDG
+4 SET EN="INVEN"
DO ^APSQSHOW
+5 DO EN^APSQDGDG
+6 KILL AZOSD
+7 QUIT
EN ;CHANGED PSOSD TO AZOSD IHS/OKCAO/POC
+1 ;W !,"Checking for Drug/Drug Interactions !",!
+2 ;IF '(PSODRUG("NDF")?1.N1"A"1.N),PSODRUG("DEA")'["S" W !,*7,*7,$S(PSODRUG("NAME")="OUTSIDE DRUG":"THIS DRUG",1:PSODRUG("NAME"))," CANNOT BE CHECKED FOR INTERACTIONS. IT HAS NO ENTRY IN NATIONAL DRUG FILE!!" ;WARN OF NO NDF IHS/OKCAO/POC 12/20/9
7
+3 ;STOP SINCE CANT CHECK IHS/OKCAO/POC
IF '(PSODRUG("NDF")?1.N1"A"1.N)
QUIT
+4 ;S (CRIT,DRG,LSI,DGI,DGS,SER,SERS)="" F S DRG=$O(AZOSD(DRG)) Q:(DRG="")!($G(PSORX("DFLG"))) I $P(AZOSD(DRG),"^",2)<10 D ;ADDED THE Q:$G WHEN STOP AT CRITICAL AND DELETE DRUG SO WONT LOOP THRU OTHER INTERACTIONS IHS/OKCAO/POC 12/3/97
+5 ;ADDED THE Q:$G WHEN STOP AT CRITICAL AND DELETE DRUG SO WONT LOOP THRU OTHER INTERACTIONS IHS/OKCAO/POC 12/3/97 GOT RID OF I ... <10
SET (CRIT,DRG,LSI,DGI,DGS,SER,SERS)=""
FOR
SET DRG=$ORDER(AZOSD(DRG))
IF (DRG="")!($GET(PSORX("DFLG")))
QUIT
Begin DoDot:1
+6 ;S NDF=$P(AZOSD(DRG),"^",7),IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG"))
+7 ;S NDF=$P(AZOSD(DRG),"^",7) W:'(NDF?1.N1"A"1.N) !,*7,*7,DRG," CANNOT BE CHECKED FOR INTERACTIONS WITH ",PSODRUG("NAME"),". ",DRG," HAS NO ENTRY IN NATIONAL DRUG FILE!!" S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),0)) I IT D BLD Q:+$G(PSORX("DFLG")
) ;ADDED FOR EACH DRUG WITH NO NDF ENTRY IHS/OKCAO/POC 12/20/97
+8 SET NDF=$PIECE(AZOSD(DRG),"^",7)
+9 ;S PSOZDEA=$P(^PSDRUG($P(^PSRX($P(AZOSD(DRG),U),0),U,6),0),U,3)
+10 ;SINCE NO ENTRY IN PSRX FILE
SET PSOZDEA=$PIECE(^PSDRUG(ARRDRIEN,0),U,3)
+11 ;DONT LOOK AT SUPPLY ITEMS
IF '(NDF?1.N1"A"1.N)
IF PSOZDEA'["S"
WRITE !!,*7,*7,DRG," CANNOT BE CHECKED FOR INTERACTIONS WITH ",PSODRUG("NAME"),". ",DRG," HAS NO ENTRY IN NATIONAL DRUG FILE!!",!
+12 ;ADDED FOR EACH DRUG WITH NO NDF ENTRY IHS/OKCAO/POC 12/20/97
SET IT=$ORDER(^PS(56,"APD",NDF,PSODRUG("NDF"),0))
IF IT
DO BLD
IF +$GET(PSORX("DFLG"))
QUIT
End DoDot:1
+13 IF '$DATA(^XUSEC("PSORPH",DUZ))
IF $GET(DGI)]""
IF +CRIT
SET PSONEW("STATUS")=4
WRITE *7,!,"DRUG INTERACTON WITH RX #s: "_LSI,!
KILL LSI,DRG,IT,NDF
+14 QUIT
TECH ;add tech entry to RX VERIFY file (#52.4)
+1 IF +CRIT
SET PSODI=1
SET (DIC,DLAYGO)="^PS(52.4,"
SET DIC(0)="L"
SET (DINUM,X)=PSOX("IRXN")
SET DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4///"_DT_";7///"_1_";7.1///"_SER_";7.2///"_DGI
KILL DD,DO
DO FILE^DICN
+2 IF $GET(DGS)'=""
SET $PIECE(^PSRX(PSOX("IRXN"),"DRI"),"^")=SERS
SET $PIECE(^PSRX(PSOX("IRXN"),"DRI"),"^",2)=DGS
KILL PSODI,CRIT,DIC,DLAYGO,DINUM,DGI,DGS,SER,SERS
QUIT
BLD IF $DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("PHARM")=DUZ
DO PHARM
QUIT
+1 ;S LSI=$P(^PSRX(+AZOSD(DRG),0),"^")_"/"_$P(^PSDRUG($P(^(0),"^",6),0),"^")_","_LSI,DGI=$P(AZOSD(DRG),"^")_","_DGI,SER=IT_","_SER I $P(AZOSD(DRG),"^",9),$P(^PS(56,IT,0),"^",4)=1 S $P(^PSRX(+AZOSD(DRG),0),"^",15)=4
+2 SET LSI="--"_"/"_$PIECE(^PSDRUG(ARRDRIEN,0),"^")_","_LSI
SET DGI=""_","_DGI
SET SER=IT_","_SER
+3 IF $PIECE(^PS(56,IT,0),"^",4)=1
SET CRIT=1
QUIT
PHARM ;pharmacist verification of drug interaction
+1 SET SER=^PS(56,IT,0)
SET DIR("?",1)="Answer 'YES' if you DO want to "_$SELECT($PIECE(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
+2 SET DIR("?")=" 'NO' if you DON'T want to "_$SELECT($PIECE(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
+3 WRITE *7,*7
SET DIR("A",1)="***"_$SELECT($PIECE(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with DRUG "_DRG
+4 SET DIR(0)="SA^1:YES;0:NO"
SET DIR("A")="Do you want to "_$SELECT($PIECE(SER,"^",4)=1:"Continue? ",1:"Intervene? ")
SET DIR("B")="N"
DO ^DIR
+5 IF 'Y
IF $PIECE(SER,"^",4)=1
SET PSORX("DFLG")=1
SET DGI=""
KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT
+6 IF Y
IF $PIECE(SER,"^",4)=1
SET PSORX("INTERVENE")=1
SET DGI=""
KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT
GOTO CRI
QUIT
+7 IF 'Y
IF $PIECE(SER,"^",4)=2
KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT
QUIT
+8 ;ADDED IHS/OKCAO/POC 12/3/97
IF Y
IF $PIECE(SER,"^",4)=2
SET PSORX("INTERVENE")=2
SET DGI=""
KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT
DO ^PSORXI
KILL PSORX("INTERVENE")
+9 QUIT
CRI ;process new drug interactions entered by pharmacist
+1 ;K DIR G:$P(AZOSD(DRG),"^",9) CRITN S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P"
+2 ;ALWAYS DO AN INTERVENTION IHS/OKCAO/POC 11/19/97
KILL DIR
SET DIR("A",1)=""
SET DIR("A",2)="Do you want to Process medication"
SET DIR("A")=PSODRUG("NAME")_": "
SET DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY"
SET DIR("B")="P"
+3 SET DIR("?",1)="Enter '1' or 'P' to Activate medication"
SET DIR("?")=" '0' or 'A' to Abort Order Entry process"
DO ^DIR
KILL X1,DIR
IF 'Y
SET PSORX("DFLG")=1
SET DGI=""
KILL DTOUT,DIRUT,DIROUT,DUOUT,PSORX("INTERVENE")
QUIT
+4 IF $PIECE(SER,"^",4)=1
Begin DoDot:1
+5 DO SIG^XUSESIG
IF X1=""
KILL PSORX("INTERVENE")
SET PSORX("DFLG")=1
QUIT
+6 SET PSORX("INTERVENE")=$PIECE(SER,"^",4)
+7 ;IHS/OKCAO/POC 12/3/97
DO ^PSORXI
KILL PSORX("INTERVENE")
End DoDot:1
+8 KILL DUOUT,DTOUT,DIRUT,DIROUT
QUIT
CRITN ;process multiple new drug interactions
+1 ;IT DOESNT WORK ??
+2 KILL X1,DIR
SET DIR("A",1)=""
SET DIR("A",2)="Do you want to Delete: "
SET DIR("A",3)=" 1. NEW medication "_PSODRUG("NAME")
SET DIR("A",4)=" 2. ACTIVE New Rx #"_$PIECE(^PSRX($PIECE(AZOSD(DRG),"^"),0),"^")_" DRUG: "_DRG
+3 SET DIR("A",5)=" 3. Both 1 and 2"
SET DIR("A")=" 4. Continue ?: "
SET DIR(0)="SA^1:NEW MEDICATION;2:ACTIVE New RX #"_DGI_" "_DRG_";3:BOTH;4:CONTINUE"
+4 SET DIR("?",1)="Enter '1' or 'N' to Delete New Medication and Activate RX #"_$PIECE(^PSRX(+AZOSD(DRG),0),"^")
SET DIR("?",2)=" '2' or 'A' to Delete Active RX #"_$PIECE(^PSRX(+AZOSD(DRG),0),"^")_" and Abort New Order Entry"
+5 SET DIR("?",3)=" '3' or 'B' to Delete Both"
SET DIR("?")=" '4' or 'C' to do nothing to either RX"
DO ^DIR
KILL DIR
+6 IF Y=1
SET PSORX("DFLG")=1
SET DGI=""
SET PSHLDDRG=PSODRUG("IEN")
SET PSODRUG("IEN")=$PIECE(^PSRX($PIECE(AZOSD(DRG),"^"),0),"^",6)
DO ^PSORXI
SET PSODRUG("IEN")=PSHLDDRG
KILL DTOUT,DIRUT,DIROUT,DUOUT,PSHLDDRG
QUIT
+7 IF Y=2
SET (DA,PSOHOLDA)=+AZOSD(DRG)
DO MESS
DO ENQ^PSORXDL
SET DA=PSOHOLDA
DO EN1^PSORXI(.DA)
DO PPL
KILL AZOSD(DRG),DTOUT,DIROUT,DIRUT,DUOUT,PSOHOLDA
SET AZOSD=AZOSD-1
QUIT
+8 IF Y=3
SET (DA,PSOHOLDA)=+AZOSD(DRG)
SET AZOSD=AZOSD-1
SET PSORX("DFLG")=1
DO MESS
DO ENQ^PSORXDL
SET DA=PSOHOLDA
DO EN1^PSORXI(.DA)
DO PPL
KILL AZOSD(DRG),PSOHOLDA
+9 KILL DTOUT,DIROUT,DIRUT,DUOUT
+10 QUIT
MESS WRITE !!,"Deleting Rx: ",$PIECE($GET(^PSRX(DA,0)),"^")," ","Drug: ",$PIECE($GET(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0)),"^"),!
QUIT
PPL FOR PSOSL=0:0
SET PSOSL=$ORDER(PSORX("PSOL",PSOSL))
IF 'PSOSL
QUIT
SET PSOX2=PSOSL
+1 IF $GET(PSOX2)
Begin DoDot:1
+2 FOR PSOSL=0:1:PSOX2
SET PSOSL=$ORDER(PSORX("PSOL",PSOSL))
IF 'PSOSL
QUIT
FOR ENT=1:1:$LENGTH(PSORX("PSOL",PSOSL),",")
IF $PIECE(PSORX("PSOL",PSOSL),",",ENT)=$PIECE(AZOSD(DRG),"^")
SET PSOL(PSOSL,ENT)=""
+3 FOR PSOL=0:0
SET PSOL=$ORDER(PSOL(PSOL))
IF 'PSOL
QUIT
FOR ENT=0:0
SET ENT=$ORDER(PSOL(PSOL,ENT))
IF 'ENT
QUIT
Begin DoDot:2
+4 IF ENT=1
IF '$PIECE(PSORX("PSOL",PSOL),",",2)
KILL PSORX("PSOL",PSOL)
QUIT
+5 IF ENT=1
IF $PIECE(PSORX("PSOL",PSOL),",",2)
SET PSORX("PSOL",PSOL)=$PIECE(PSORX("PSOL",PSOL),",",2,99)
QUIT
+6 SET PSORX("PSOL",PSOL)=$PIECE(PSORX("PSOL",PSOL),",",1,ENT-1)_","_$PIECE(PSORX("PSOL",PSOL),",",ENT+1,99)
End DoDot:2
End DoDot:1
+7 KILL PSOX2,PSOSL,PSOL,ENT
QUIT
