PSSUTIL ;BIR/RTR-utility routine for NDF changes ;04/04/00
;;1.0;PHARMACY DATA MANAGEMENT;**34,38,147**;9/30/97;Build 16
;
;Reference to PS(50.607 supported by DBIA 2221
EN(PSSDIEN) ;Receive Drug entries unmatched as a result of NDF changes
;Not called, NDF deletes the possible and local possible dosages
Q
EN1(PSSDIEN,PSSTALK) ;Receive Drug entries that have been unmatched
N PSSLD,PSSLOCV,PSSPWXEX
S PSSLOCV=$O(^PS(59.7,0))
;I $P($G(^PS(59.7,+$G(PSSLOCV),80)),"^",3)<2 Q
W !!,"Deleting Possible Dosages.."
K ^PSDRUG(PSSDIEN,"DOS"),^PSDRUG(PSSDIEN,"DOS1")
H 1 W "."
I '$G(PSSTALK) K ^PSDRUG(PSSDIEN,"DOS2") G EQ
I '$O(^PSDRUG(PSSDIEN,"DOS2",0)) W !
I $O(^PSDRUG(PSSDIEN,"DOS2",0)) D DASK D W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Delete these Local Possible Dosages" D ^DIR K DIR I Y=1 W !!,"Deleting Local Possible Dosages.." K ^PSDRUG(PSSDIEN,"DOS2") H 1 W "." W ! G EQ
.S PSSPWXEX=0 W !!,"LOCAL POSSIBLE DOSAGES:"
.W ! F PSSLD=0:0 S PSSLD=$O(^PSDRUG(PSSDIEN,"DOS2",PSSLD)) Q:'PSSLD!(PSSPWXEX) D
..D:($Y+5)>IOSL ZASK Q:PSSPWXEX W !,$P($G(^PSDRUG(PSSDIEN,"DOS2",PSSLD,0)),"^")_" "_$S($P($G(^(0)),"^",2)="":"(No package)",1:"(Package -> "_$P($G(^(0)),"^",2)_")") D DOSEADD
I $O(^PSDRUG(PSSDIEN,"DOS2",0)) W !!,"Local Possible Dosages not deleted.",!
EQ Q
EN2(PSSDIEN,PSSTALK) ;Receive Drug entries matched to NDF
;Do we need entry point on an Orderable Item match (not matched to NDF)
Q:'$D(^PSDRUG(PSSDIEN,0))
K ^PSDRUG(PSSDIEN,"DOS"),^PSDRUG(PSSDIEN,"DOS1")
N PSSLOC,PSSO,PSSI,PSSND,PSSND1,PSSBOTH,PSSONLYI,PSSONLYO,PSSNODE,PSSDF,PSSST,PSSUN,PSSTOT,PSSTOTX,PSSDUPD,PSSTODOS,PSSFLAG
S PSSLOC=$O(^PS(59.7,0))
;I $P($G(^PS(59.7,+$G(PSSLOC),80)),"^",3)<3 Q
I $G(PSSTALK) W !!,"Resetting Possible Dosages..",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
S PSSBOTH=1
S (PSSONLYI,PSSONLYO,PSSFLAG)=0
S PSSND=$P($G(^PSDRUG(PSSDIEN,"ND")),"^",3),PSSND1=$P($G(^("ND")),"^") I 'PSSND!('PSSND1) G LOC
S PSSNODE=$$DFSU^PSNAPIS(PSSND1,PSSND) S PSSDF=$P(PSSNODE,"^"),PSSST=$P(PSSNODE,"^",4),PSSUN=$P(PSSNODE,"^",5)
I 'PSSDF!('PSSUN)!($G(PSSST)="") G LOC
I '$D(^PS(50.606,PSSDF,0))!('$D(^PS(50.607,PSSUN,0))) G LOC
I PSSST'?.N&(PSSST'?.N1".".N) G LOC
S (PSSI,PSSO)=0
I $D(^PS(50.606,"ACONI",PSSDF,PSSUN)),$O(^PS(50.606,"ADUPI",PSSDF,0)) S PSSI=1
I $D(^PS(50.606,"ACONO",PSSDF,PSSUN)),$O(^PS(50.606,"ADUPO",PSSDF,0)) S PSSO=1
I 'PSSO,'PSSI G LOC
I PSSI,'PSSO D S:PSSTOT>1 PSSTOTX=PSSTOT-1,^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN,PSSONLYO=1,PSSBOTH=0,^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$G(PSSTOTX)_"^"_$G(PSSTOTX) G LOC
.S PSSTOT=1 F PSSDUPD=0:0 S PSSDUPD=$O(^PS(50.606,"ADUPI",PSSDF,PSSDUPD)) Q:'PSSDUPD D
..S PSSTODOS=PSSDUPD*PSSST
..S ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^I",^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)="" S PSSTOT=PSSTOT+1
I PSSO,'PSSI D S:PSSTOT>1 PSSTOTX=PSSTOT-1,^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN,PSSONLYI=1,PSSBOTH=0,^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$G(PSSTOTX)_"^"_$G(PSSTOTX) G LOC
.S PSSTOT=1 F PSSDUPD=0:0 S PSSDUPD=$O(^PS(50.606,"ADUPO",PSSDF,PSSDUPD)) Q:'PSSDUPD D
..S PSSTODOS=PSSDUPD*PSSST
..S ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^O",^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)="" S PSSTOT=PSSTOT+1
I PSSO,PSSI D S:PSSTOT>1 PSSTOTX=PSSTOT-1,PSSFLAG=1,^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN,^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$G(PSSTOTX)_"^"_$G(PSSTOTX)
.S PSSTOT=1 F PSSDUPD=0:0 S PSSDUPD=$O(^PS(50.606,"ADUPI",PSSDF,PSSDUPD)) Q:'PSSDUPD D
..S PSSTODOS=PSSDUPD*PSSST
..S ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS S $P(^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0),"^",3)=$S($D(^PS(50.606,"ADUPO",PSSDF,PSSDUPD)):"IO",1:"I") S ^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)="" S PSSTOT=PSSTOT+1
I PSSO,PSSI D S:PSSTOT>1 PSSTOTX=PSSTOT-1,PSSFLAG=1,^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN,^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$G(PSSTOTX)_"^"_$G(PSSTOTX)
.F PSSDUPD=0:0 S PSSDUPD=$O(^PS(50.606,"ADUPO",PSSDF,PSSDUPD)) Q:'PSSDUPD D
..I $D(^PS(50.606,"ADUPI",PSSDF,PSSDUPD)) Q
..S PSSTODOS=PSSDUPD*PSSST
..S ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^O",^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)="" S PSSTOT=PSSTOT+1
Q
LOC ;Set local possible dosages
N PSSOITEM,PSSOID,PSSLTOT,PSSLTOTX,PSDUPDPT,PSNOUN,PSNOUNPA,PSNOUNPT,PSALL,PSDOD,PSSLPT,PSSLPTX,PSSLPNO,PSSLP,PSSNL,PSSNLF,PSSNLX
S PSSOITEM=$P($G(^PSDRUG(PSSDIEN,2)),"^") Q:'PSSOITEM
S PSSOID=$P($G(^PS(50.7,PSSOITEM,0)),"^",2) Q:'PSSOID
Q:'$O(^PS(50.606,PSSOID,"NOUN",0))
I $O(^PSDRUG(PSSDIEN,"DOS2",0)) G LOCMRG
I '$G(PSSTALK) G QUIET
W ! K DIR S DIR("A")="This drug has no Local Possible Dosages, do you want to create them",DIR("B")="Y",DIR(0)="Y"
S DIR("?")=" ",DIR("?",1)="If you answer 'YES', Local Possible Dosages will be created for this drug using",DIR("?",2)="nouns associated with the "_$P($G(^PS(50.606,+$G(PSSOID),0)),"^")_" Dosage Form."
D ^DIR K DIR I Y'=1 Q
W !!,"Setting Local Possible Dosages..",!
K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
QUIET ;
I $O(^PS(50.606,PSSOID,"DUPD",0)) D S:PSSLTOT>1 PSSLTOTX=PSSLTOT-1,^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$G(PSSLTOTX)_"^"_$G(PSSLTOTX) Q
.S PSSLTOT=1
.F PSNOUN=0:0 S PSNOUN=$O(^PS(50.606,PSSOID,"NOUN",PSNOUN)) Q:'PSNOUN S PSNOUNPT=$P($G(^(PSNOUN,0)),"^"),PSNOUNPA=$P($G(^(0)),"^",2) D:PSNOUNPT'=""
..Q:PSNOUNPA=""
..F PSDOD=0:0 S PSDOD=$O(^PS(50.606,PSSOID,"DUPD",PSDOD)) Q:'PSDOD S PSDUPDPT=$P($G(^(PSDOD,0)),"^") D:PSDUPDPT'=""
...I $G(PSSONLYO),PSNOUNPA'["O" Q
...I $G(PSSONLYI),PSNOUNPA'["I" Q
...D TEST^PSSDOSCR
...S PSALL=$G(PSDUPDPT)_" "_$S($G(PSSNLF):$G(PSSNLX),1:$G(PSNOUNPT)) K PSSNL,PSSNLF,PSSNLX
...S ^PSDRUG(PSSDIEN,"DOS2",PSSLTOT,0)=$G(PSALL)_"^"_$G(PSNOUNPA),^PSDRUG(PSSDIEN,"DOS2","B",$E(PSALL,1,30),PSSLTOT)="" S PSSLTOT=PSSLTOT+1
S PSSLTOT=1 F PSNOUN=0:0 S PSNOUN=$O(^PS(50.606,PSSOID,"NOUN",PSNOUN)) Q:'PSNOUN S PSNOUNPT=$P($G(^(PSNOUN,0)),"^"),PSNOUNPA=$P($G(^(0)),"^",2) D:PSNOUNPT'=""
.Q:PSNOUNPA=""
.I $G(PSSONLYI),PSNOUNPA'["I" Q
.I $G(PSSONLYO),PSNOUNPA'["O" Q
.S ^PSDRUG(PSSDIEN,"DOS2",PSSLTOT,0)=PSNOUNPT_"^"_$G(PSNOUNPA),^PSDRUG(PSSDIEN,"DOS2","B",$E(PSNOUNPT,1,30),PSSLTOT)="" S PSSLTOT=PSSLTOT+1
I PSSLTOT>1 S PSSLTOTX=PSSLTOT-1 S ^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$G(PSSLTOTX)_"^"_$G(PSSLTOTX)
Q
LOCMRG ;Merge new Local Possible Dosages with existing ones
N PSSLIEN,PSSLIENX,PSSPWZEX
I '$G(PSSTALK) G QUIET1
W !!,"This drug has the following Local Possible Dosages:",!
S PSSPWZEX=0 F PSSLIEN=0:0 S PSSLIEN=$O(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN)) Q:'PSSLIEN!(PSSPWZEX) D
.D:($Y+5)>IOSL XASK Q:PSSPWZEX S PSSLIENX=$P($G(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0)),"^")
.I $L(PSSLIENX)'>53 W !,PSSLIENX,?55,"PACKAGE: ",$P($G(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0)),"^",2) D DOSEADX Q
.W !,PSSLIENX,!,?55,"PACKAGE: ",$P($G(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0)),"^",2) D DOSEADX
W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to merge new Local Possible Dosages"
S DIR("?")=" ",DIR("?",1)="If you answer 'YES', any new Local Possible Dosages found based on the nouns",DIR("?",2)="associated with the "_$P($G(^PS(50.606,+$G(PSSOID),0)),"^")_" Dosage Form"
S DIR("?",3)="will be added to you current Local Possible Dosages."
D ^DIR K DIR I Y'=1 Q
W !!,"Setting Local Possible Dosages..",!
K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
QUIET1 ;
I $O(^PS(50.606,PSSOID,"DUPD",0)) D Q
.F PSNOUN=0:0 S PSNOUN=$O(^PS(50.606,PSSOID,"NOUN",PSNOUN)) Q:'PSNOUN S PSNOUNPT=$P($G(^(PSNOUN,0)),"^"),PSNOUNPA=$P($G(^(0)),"^",2) D:PSNOUNPT'=""
..Q:PSNOUNPA=""
..F PSDOD=0:0 S PSDOD=$O(^PS(50.606,PSSOID,"DUPD",PSDOD)) Q:'PSDOD S PSDUPDPT=$P($G(^(PSDOD,0)),"^") D:PSDUPDPT'=""
...I $G(PSSONLYO),PSNOUNPA'["O" Q
...I $G(PSSONLYI),PSNOUNPA'["I" Q
...D TEST^PSSDOSCR
...S PSALL=$G(PSDUPDPT)_" "_$S($G(PSSNLF):$G(PSSNLX),1:$G(PSNOUNPT)) K PSSNL,PSSNLF,PSSNLX
...S (PSSLPT,PSSLPTX,PSSLPNO)=0 F PSSLP=0:0 S PSSLP=$O(^PSDRUG(PSSDIEN,"DOS2",PSSLP)) Q:'PSSLP S PSSLPTX=PSSLPTX+1 S PSSLPT=PSSLP I PSALL=$P($G(^PSDRUG(PSSDIEN,"DOS2",PSSLP,0)),"^") S PSSLPNO=1
...Q:PSSLPNO
...S PSSLPT=PSSLPT+1,PSSLPTX=PSSLPTX+1
...S ^PSDRUG(PSSDIEN,"DOS2",PSSLPT,0)=$G(PSALL)_"^"_$G(PSNOUNPA),^PSDRUG(PSSDIEN,"DOS2","B",$E(PSALL,1,30),PSSLPT)="",^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$G(PSSLPT)_"^"_$G(PSSLPTX)
F PSNOUN=0:0 S PSNOUN=$O(^PS(50.606,PSSOID,"NOUN",PSNOUN)) Q:'PSNOUN S PSNOUNPT=$P($G(^(PSNOUN,0)),"^"),PSNOUNPA=$P($G(^(0)),"^",2) D:PSNOUNPT'=""
.Q:PSNOUNPA=""
.I $G(PSSONLYO),PSNOUNPA'["O" Q
.I $G(PSSONLYI),PSNOUNPA'["I" Q
.S (PSSLPT,PSSLPTX,PSSLPNO)=0 F PSSLP=0:0 S PSSLP=$O(^PSDRUG(PSSDIEN,"DOS2",PSSLP)) Q:'PSSLP S PSSLPTX=PSSLPTX+1 S PSSLPT=PSSLP I PSNOUNPT=$P($G(^PSDRUG(PSSDIEN,"DOS2",PSSLP,0)),"^") S PSSLPNO=1
.Q:PSSLPNO
.S PSSLPT=PSSLPT+1,PSSLPTX=PSSLPTX+1
.S ^PSDRUG(PSSDIEN,"DOS2",PSSLPT,0)=$G(PSNOUNPT)_"^"_$G(PSNOUNPA),^PSDRUG(PSSDIEN,"DOS2","B",$E(PSNOUNPT,1,30),PSSLPT)="",^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$G(PSSLPT)_"^"_$G(PSSLPTX)
Q
;
;
DOSEADD ;New fields added with PSS*1*147
N PSSPW1,PSSPW2,PSSPW3,PSSPW4,PSSPW5,PSSPW6,PSSPW7,PSSPW8
S PSSPW7=""
S PSSPW1=$G(^PSDRUG(PSSDIEN,"DOS2",PSSLD,0))
S PSSPW2=$P(PSSPW1,"^",3)
S PSSPW3=$S($E(PSSPW2)=".":"0",1:"")_PSSPW2
D:($Y+5)>IOSL ZASK Q:PSSPWXEX W !?3,"BCMA UNITS PER DOSE: "_PSSPW3
S PSSPW4=$P(PSSPW1,"^",5),PSSPW5=$P(PSSPW1,"^",6)
S PSSPW6=$S($E(PSSPW5)=".":"0",1:"")_PSSPW5
I PSSPW4 S PSSPW7=$P($G(^PS(51.24,+PSSPW4,0)),"^")
S PSSPW8=$L(PSSPW6)+$L(PSSPW7)
D:($Y+5)>IOSL ZASK Q:PSSPWXEX I PSSPW8<49 W !?3,"NUMERIC DOSE: "_PSSPW6_" DOSE UNIT: "_PSSPW7 Q
W !?3,"NUMERIC DOSE: "_PSSPW6
W !?3,"DOSE UNIT: "_PSSPW7
Q
;
;
DOSEADX ;New fields added with PSS*1*147
N PSSPWX1,PSSPWX2,PSSPWX3,PSSPWX4,PSSPWX5,PSSPWX6,PSSPWX7,PSSPWX8
S PSSPWX7=""
S PSSPWX1=$G(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0))
S PSSPWX2=$P(PSSPWX1,"^",3)
S PSSPWX3=$S($E(PSSPWX2)=".":"0",1:"")_PSSPWX2
D:($Y+5)>IOSL XASK Q:PSSPWZEX W !?3,"BCMA UNITS PER DOSE: "_PSSPWX3
S PSSPWX4=$P(PSSPWX1,"^",5),PSSPWX5=$P(PSSPWX1,"^",6)
S PSSPWX6=$S($E(PSSPWX5)=".":"0",1:"")_PSSPWX5
I PSSPWX4 S PSSPWX7=$P($G(^PS(51.24,+PSSPWX4,0)),"^")
S PSSPWX8=$L(PSSPWX6)+$L(PSSPWX7)
D:($Y+5)>IOSL XASK Q:PSSPWZEX I PSSPWX8<49 W !?3,"NUMERIC DOSE: "_PSSPWX6_" DOSE UNIT: "_PSSPWX7 Q
W !?3,"NUMERIC DOSE: "_PSSPWX6
W !?3,"DOSE UNIT: "_PSSPWX7
Q
;
;
ZASK ;Ask to continue
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue,'^' to exit the list" D ^DIR K DIR I 'Y S PSSPWXEX=1
W @IOF
Q
;
;
XASK ;Ask to continue
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue,'^' to exit the list" D ^DIR K DIR I 'Y S PSSPWZEX=1
W @IOF
Q
;
;
DASK ;Ask to continue
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
W @IOF
Q
PSSUTIL ;BIR/RTR-utility routine for NDF changes ;04/04/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**34,38,147**;9/30/97;Build 16
+2 ;
+3 ;Reference to PS(50.607 supported by DBIA 2221
EN(PSSDIEN) ;Receive Drug entries unmatched as a result of NDF changes
+1 ;Not called, NDF deletes the possible and local possible dosages
+2 QUIT
EN1(PSSDIEN,PSSTALK) ;Receive Drug entries that have been unmatched
+1 NEW PSSLD,PSSLOCV,PSSPWXEX
+2 SET PSSLOCV=$ORDER(^PS(59.7,0))
+3 ;I $P($G(^PS(59.7,+$G(PSSLOCV),80)),"^",3)<2 Q
+4 WRITE !!,"Deleting Possible Dosages.."
+5 KILL ^PSDRUG(PSSDIEN,"DOS"),^PSDRUG(PSSDIEN,"DOS1")
+6 HANG 1
WRITE "."
+7 IF '$GET(PSSTALK)
KILL ^PSDRUG(PSSDIEN,"DOS2")
GOTO EQ
+8 IF '$ORDER(^PSDRUG(PSSDIEN,"DOS2",0))
WRITE !
+9 IF $ORDER(^PSDRUG(PSSDIEN,"DOS2",0))
DO DASK
Begin DoDot:1
+10 SET PSSPWXEX=0
WRITE !!,"LOCAL POSSIBLE DOSAGES:"
+11 WRITE !
FOR PSSLD=0:0
SET PSSLD=$ORDER(^PSDRUG(PSSDIEN,"DOS2",PSSLD))
IF 'PSSLD!(PSSPWXEX)
QUIT
Begin DoDot:2
+12 IF ($Y+5)>IOSL
DO ZASK
IF PSSPWXEX
QUIT
WRITE !,$PIECE($GET(^PSDRUG(PSSDIEN,"DOS2",PSSLD,0)),"^")_" "_$SELECT($PIECE($GET(^(0)),"^",2)="":"(No package)",1:"(Package -> "_$PIECE($GET(^(0)),"^",2)_")")
DO DOSEADD
End DoDot:2
End DoDot:1
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Delete these Local Possible Dosages"
DO ^DIR
KILL DIR
IF Y=1
WRITE !!,"Deleting Local Possible Dosages.."
KILL ^PSDRUG(PSSDIEN,"DOS2")
HANG 1
WRITE "."
WRITE !
GOTO EQ
+13 IF $ORDER(^PSDRUG(PSSDIEN,"DOS2",0))
WRITE !!,"Local Possible Dosages not deleted.",!
EQ QUIT
EN2(PSSDIEN,PSSTALK) ;Receive Drug entries matched to NDF
+1 ;Do we need entry point on an Orderable Item match (not matched to NDF)
+2 IF '$DATA(^PSDRUG(PSSDIEN,0))
QUIT
+3 KILL ^PSDRUG(PSSDIEN,"DOS"),^PSDRUG(PSSDIEN,"DOS1")
+4 NEW PSSLOC,PSSO,PSSI,PSSND,PSSND1,PSSBOTH,PSSONLYI,PSSONLYO,PSSNODE,PSSDF,PSSST,PSSUN,PSSTOT,PSSTOTX,PSSDUPD,PSSTODOS,PSSFLAG
+5 SET PSSLOC=$ORDER(^PS(59.7,0))
+6 ;I $P($G(^PS(59.7,+$G(PSSLOC),80)),"^",3)<3 Q
+7 IF $GET(PSSTALK)
WRITE !!,"Resetting Possible Dosages..",!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+8 SET PSSBOTH=1
+9 SET (PSSONLYI,PSSONLYO,PSSFLAG)=0
+10 SET PSSND=$PIECE($GET(^PSDRUG(PSSDIEN,"ND")),"^",3)
SET PSSND1=$PIECE($GET(^("ND")),"^")
IF 'PSSND!('PSSND1)
GOTO LOC
+11 SET PSSNODE=$$DFSU^PSNAPIS(PSSND1,PSSND)
SET PSSDF=$PIECE(PSSNODE,"^")
SET PSSST=$PIECE(PSSNODE,"^",4)
SET PSSUN=$PIECE(PSSNODE,"^",5)
+12 IF 'PSSDF!('PSSUN)!($GET(PSSST)="")
GOTO LOC
+13 IF '$DATA(^PS(50.606,PSSDF,0))!('$DATA(^PS(50.607,PSSUN,0)))
GOTO LOC
+14 IF PSSST'?.N&(PSSST'?.N1".".N)
GOTO LOC
+15 SET (PSSI,PSSO)=0
+16 IF $DATA(^PS(50.606,"ACONI",PSSDF,PSSUN))
IF $ORDER(^PS(50.606,"ADUPI",PSSDF,0))
SET PSSI=1
+17 IF $DATA(^PS(50.606,"ACONO",PSSDF,PSSUN))
IF $ORDER(^PS(50.606,"ADUPO",PSSDF,0))
SET PSSO=1
+18 IF 'PSSO
IF 'PSSI
GOTO LOC
+19 IF PSSI
IF 'PSSO
Begin DoDot:1
+20 SET PSSTOT=1
FOR PSSDUPD=0:0
SET PSSDUPD=$ORDER(^PS(50.606,"ADUPI",PSSDF,PSSDUPD))
IF 'PSSDUPD
QUIT
Begin DoDot:2
+21 SET PSSTODOS=PSSDUPD*PSSST
+22 SET ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^I"
SET ^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)=""
SET PSSTOT=PSSTOT+1
End DoDot:2
End DoDot:1
IF PSSTOT>1
SET PSSTOTX=PSSTOT-1
SET ^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN
SET PSSONLYO=1
SET PSSBOTH=0
SET ^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$GET(PSSTOTX)_"^"_$GET(PSSTOTX)
GOTO LOC
+23 IF PSSO
IF 'PSSI
Begin DoDot:1
+24 SET PSSTOT=1
FOR PSSDUPD=0:0
SET PSSDUPD=$ORDER(^PS(50.606,"ADUPO",PSSDF,PSSDUPD))
IF 'PSSDUPD
QUIT
Begin DoDot:2
+25 SET PSSTODOS=PSSDUPD*PSSST
+26 SET ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^O"
SET ^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)=""
SET PSSTOT=PSSTOT+1
End DoDot:2
End DoDot:1
IF PSSTOT>1
SET PSSTOTX=PSSTOT-1
SET ^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN
SET PSSONLYI=1
SET PSSBOTH=0
SET ^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$GET(PSSTOTX)_"^"_$GET(PSSTOTX)
GOTO LOC
+27 IF PSSO
IF PSSI
Begin DoDot:1
+28 SET PSSTOT=1
FOR PSSDUPD=0:0
SET PSSDUPD=$ORDER(^PS(50.606,"ADUPI",PSSDF,PSSDUPD))
IF 'PSSDUPD
QUIT
Begin DoDot:2
+29 SET PSSTODOS=PSSDUPD*PSSST
+30 SET ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS
SET $PIECE(^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0),"^",3)=$SELECT($DATA(^PS(50.606,"ADUPO",PSSDF,PSSDUPD)):"IO",1:"I")
SET ^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)=""
SET PSSTOT=PSSTOT+1
End DoDot:2
End DoDot:1
IF PSSTOT>1
SET PSSTOTX=PSSTOT-1
SET PSSFLAG=1
SET ^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN
SET ^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$GET(PSSTOTX)_"^"_$GET(PSSTOTX)
+31 IF PSSO
IF PSSI
Begin DoDot:1
+32 FOR PSSDUPD=0:0
SET PSSDUPD=$ORDER(^PS(50.606,"ADUPO",PSSDF,PSSDUPD))
IF 'PSSDUPD
QUIT
Begin DoDot:2
+33 IF $DATA(^PS(50.606,"ADUPI",PSSDF,PSSDUPD))
QUIT
+34 SET PSSTODOS=PSSDUPD*PSSST
+35 SET ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^O"
SET ^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)=""
SET PSSTOT=PSSTOT+1
End DoDot:2
End DoDot:1
IF PSSTOT>1
SET PSSTOTX=PSSTOT-1
SET PSSFLAG=1
SET ^PSDRUG(PSSDIEN,"DOS")=PSSST_"^"_PSSUN
SET ^PSDRUG(PSSDIEN,"DOS1",0)="^50.0903^"_$GET(PSSTOTX)_"^"_$GET(PSSTOTX)
+36 QUIT
LOC ;Set local possible dosages
+1 NEW PSSOITEM,PSSOID,PSSLTOT,PSSLTOTX,PSDUPDPT,PSNOUN,PSNOUNPA,PSNOUNPT,PSALL,PSDOD,PSSLPT,PSSLPTX,PSSLPNO,PSSLP,PSSNL,PSSNLF,PSSNLX
+2 SET PSSOITEM=$PIECE($GET(^PSDRUG(PSSDIEN,2)),"^")
IF 'PSSOITEM
QUIT
+3 SET PSSOID=$PIECE($GET(^PS(50.7,PSSOITEM,0)),"^",2)
IF 'PSSOID
QUIT
+4 IF '$ORDER(^PS(50.606,PSSOID,"NOUN",0))
QUIT
+5 IF $ORDER(^PSDRUG(PSSDIEN,"DOS2",0))
GOTO LOCMRG
+6 IF '$GET(PSSTALK)
GOTO QUIET
+7 WRITE !
KILL DIR
SET DIR("A")="This drug has no Local Possible Dosages, do you want to create them"
SET DIR("B")="Y"
SET DIR(0)="Y"
+8 SET DIR("?")=" "
SET DIR("?",1)="If you answer 'YES', Local Possible Dosages will be created for this drug using"
SET DIR("?",2)="nouns associated with the "_$PIECE($GET(^PS(50.606,+$GET(PSSOID),0)),"^")_" Dosage Form."
+9 DO ^DIR
KILL DIR
IF Y'=1
QUIT
+10 WRITE !!,"Setting Local Possible Dosages..",!
+11 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIET ;
+1 IF $ORDER(^PS(50.606,PSSOID,"DUPD",0))
Begin DoDot:1
+2 SET PSSLTOT=1
+3 FOR PSNOUN=0:0
SET PSNOUN=$ORDER(^PS(50.606,PSSOID,"NOUN",PSNOUN))
IF 'PSNOUN
QUIT
SET PSNOUNPT=$PIECE($GET(^(PSNOUN,0)),"^")
SET PSNOUNPA=$PIECE($GET(^(0)),"^",2)
IF PSNOUNPT'=""
Begin DoDot:2
+4 IF PSNOUNPA=""
QUIT
+5 FOR PSDOD=0:0
SET PSDOD=$ORDER(^PS(50.606,PSSOID,"DUPD",PSDOD))
IF 'PSDOD
QUIT
SET PSDUPDPT=$PIECE($GET(^(PSDOD,0)),"^")
IF PSDUPDPT'=""
Begin DoDot:3
+6 IF $GET(PSSONLYO)
IF PSNOUNPA'["O"
QUIT
+7 IF $GET(PSSONLYI)
IF PSNOUNPA'["I"
QUIT
+8 DO TEST^PSSDOSCR
+9 SET PSALL=$GET(PSDUPDPT)_" "_$SELECT($GET(PSSNLF):$GET(PSSNLX),1:$GET(PSNOUNPT))
KILL PSSNL,PSSNLF,PSSNLX
+10 SET ^PSDRUG(PSSDIEN,"DOS2",PSSLTOT,0)=$GET(PSALL)_"^"_$GET(PSNOUNPA)
SET ^PSDRUG(PSSDIEN,"DOS2","B",$EXTRACT(PSALL,1,30),PSSLTOT)=""
SET PSSLTOT=PSSLTOT+1
End DoDot:3
End DoDot:2
End DoDot:1
IF PSSLTOT>1
SET PSSLTOTX=PSSLTOT-1
SET ^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$GET(PSSLTOTX)_"^"_$GET(PSSLTOTX)
QUIT
+11 SET PSSLTOT=1
FOR PSNOUN=0:0
SET PSNOUN=$ORDER(^PS(50.606,PSSOID,"NOUN",PSNOUN))
IF 'PSNOUN
QUIT
SET PSNOUNPT=$PIECE($GET(^(PSNOUN,0)),"^")
SET PSNOUNPA=$PIECE($GET(^(0)),"^",2)
IF PSNOUNPT'=""
Begin DoDot:1
+12 IF PSNOUNPA=""
QUIT
+13 IF $GET(PSSONLYI)
IF PSNOUNPA'["I"
QUIT
+14 IF $GET(PSSONLYO)
IF PSNOUNPA'["O"
QUIT
+15 SET ^PSDRUG(PSSDIEN,"DOS2",PSSLTOT,0)=PSNOUNPT_"^"_$GET(PSNOUNPA)
SET ^PSDRUG(PSSDIEN,"DOS2","B",$EXTRACT(PSNOUNPT,1,30),PSSLTOT)=""
SET PSSLTOT=PSSLTOT+1
End DoDot:1
+16 IF PSSLTOT>1
SET PSSLTOTX=PSSLTOT-1
SET ^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$GET(PSSLTOTX)_"^"_$GET(PSSLTOTX)
+17 QUIT
LOCMRG ;Merge new Local Possible Dosages with existing ones
+1 NEW PSSLIEN,PSSLIENX,PSSPWZEX
+2 IF '$GET(PSSTALK)
GOTO QUIET1
+3 WRITE !!,"This drug has the following Local Possible Dosages:",!
+4 SET PSSPWZEX=0
FOR PSSLIEN=0:0
SET PSSLIEN=$ORDER(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN))
IF 'PSSLIEN!(PSSPWZEX)
QUIT
Begin DoDot:1
+5 IF ($Y+5)>IOSL
DO XASK
IF PSSPWZEX
QUIT
SET PSSLIENX=$PIECE($GET(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0)),"^")
+6 IF $LENGTH(PSSLIENX)'>53
WRITE !,PSSLIENX,?55,"PACKAGE: ",$PIECE($GET(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0)),"^",2)
DO DOSEADX
QUIT
+7 WRITE !,PSSLIENX,!,?55,"PACKAGE: ",$PIECE($GET(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0)),"^",2)
DO DOSEADX
End DoDot:1
+8 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Do you want to merge new Local Possible Dosages"
+9 SET DIR("?")=" "
SET DIR("?",1)="If you answer 'YES', any new Local Possible Dosages found based on the nouns"
SET DIR("?",2)="associated with the "_$PIECE($GET(^PS(50.606,+$GET(PSSOID),0)),"^")_" Dosage Form"
+10 SET DIR("?",3)="will be added to you current Local Possible Dosages."
+11 DO ^DIR
KILL DIR
IF Y'=1
QUIT
+12 WRITE !!,"Setting Local Possible Dosages..",!
+13 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIET1 ;
+1 IF $ORDER(^PS(50.606,PSSOID,"DUPD",0))
Begin DoDot:1
+2 FOR PSNOUN=0:0
SET PSNOUN=$ORDER(^PS(50.606,PSSOID,"NOUN",PSNOUN))
IF 'PSNOUN
QUIT
SET PSNOUNPT=$PIECE($GET(^(PSNOUN,0)),"^")
SET PSNOUNPA=$PIECE($GET(^(0)),"^",2)
IF PSNOUNPT'=""
Begin DoDot:2
+3 IF PSNOUNPA=""
QUIT
+4 FOR PSDOD=0:0
SET PSDOD=$ORDER(^PS(50.606,PSSOID,"DUPD",PSDOD))
IF 'PSDOD
QUIT
SET PSDUPDPT=$PIECE($GET(^(PSDOD,0)),"^")
IF PSDUPDPT'=""
Begin DoDot:3
+5 IF $GET(PSSONLYO)
IF PSNOUNPA'["O"
QUIT
+6 IF $GET(PSSONLYI)
IF PSNOUNPA'["I"
QUIT
+7 DO TEST^PSSDOSCR
+8 SET PSALL=$GET(PSDUPDPT)_" "_$SELECT($GET(PSSNLF):$GET(PSSNLX),1:$GET(PSNOUNPT))
KILL PSSNL,PSSNLF,PSSNLX
+9 SET (PSSLPT,PSSLPTX,PSSLPNO)=0
FOR PSSLP=0:0
SET PSSLP=$ORDER(^PSDRUG(PSSDIEN,"DOS2",PSSLP))
IF 'PSSLP
QUIT
SET PSSLPTX=PSSLPTX+1
SET PSSLPT=PSSLP
IF PSALL=$PIECE($GET(^PSDRUG(PSSDIEN,"DOS2",PSSLP,0)),"^")
SET PSSLPNO=1
+10 IF PSSLPNO
QUIT
+11 SET PSSLPT=PSSLPT+1
SET PSSLPTX=PSSLPTX+1
+12 SET ^PSDRUG(PSSDIEN,"DOS2",PSSLPT,0)=$GET(PSALL)_"^"_$GET(PSNOUNPA)
SET ^PSDRUG(PSSDIEN,"DOS2","B",$EXTRACT(PSALL,1,30),PSSLPT)=""
SET ^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$GET(PSSLPT)_"^"_$GET(PSSLPTX)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+13 FOR PSNOUN=0:0
SET PSNOUN=$ORDER(^PS(50.606,PSSOID,"NOUN",PSNOUN))
IF 'PSNOUN
QUIT
SET PSNOUNPT=$PIECE($GET(^(PSNOUN,0)),"^")
SET PSNOUNPA=$PIECE($GET(^(0)),"^",2)
IF PSNOUNPT'=""
Begin DoDot:1
+14 IF PSNOUNPA=""
QUIT
+15 IF $GET(PSSONLYO)
IF PSNOUNPA'["O"
QUIT
+16 IF $GET(PSSONLYI)
IF PSNOUNPA'["I"
QUIT
+17 SET (PSSLPT,PSSLPTX,PSSLPNO)=0
FOR PSSLP=0:0
SET PSSLP=$ORDER(^PSDRUG(PSSDIEN,"DOS2",PSSLP))
IF 'PSSLP
QUIT
SET PSSLPTX=PSSLPTX+1
SET PSSLPT=PSSLP
IF PSNOUNPT=$PIECE($GET(^PSDRUG(PSSDIEN,"DOS2",PSSLP,0)),"^")
SET PSSLPNO=1
+18 IF PSSLPNO
QUIT
+19 SET PSSLPT=PSSLPT+1
SET PSSLPTX=PSSLPTX+1
+20 SET ^PSDRUG(PSSDIEN,"DOS2",PSSLPT,0)=$GET(PSNOUNPT)_"^"_$GET(PSNOUNPA)
SET ^PSDRUG(PSSDIEN,"DOS2","B",$EXTRACT(PSNOUNPT,1,30),PSSLPT)=""
SET ^PSDRUG(PSSDIEN,"DOS2",0)="^50.0904^"_$GET(PSSLPT)_"^"_$GET(PSSLPTX)
End DoDot:1
+21 QUIT
+22 ;
+23 ;
DOSEADD ;New fields added with PSS*1*147
+1 NEW PSSPW1,PSSPW2,PSSPW3,PSSPW4,PSSPW5,PSSPW6,PSSPW7,PSSPW8
+2 SET PSSPW7=""
+3 SET PSSPW1=$GET(^PSDRUG(PSSDIEN,"DOS2",PSSLD,0))
+4 SET PSSPW2=$PIECE(PSSPW1,"^",3)
+5 SET PSSPW3=$SELECT($EXTRACT(PSSPW2)=".":"0",1:"")_PSSPW2
+6 IF ($Y+5)>IOSL
DO ZASK
IF PSSPWXEX
QUIT
WRITE !?3,"BCMA UNITS PER DOSE: "_PSSPW3
+7 SET PSSPW4=$PIECE(PSSPW1,"^",5)
SET PSSPW5=$PIECE(PSSPW1,"^",6)
+8 SET PSSPW6=$SELECT($EXTRACT(PSSPW5)=".":"0",1:"")_PSSPW5
+9 IF PSSPW4
SET PSSPW7=$PIECE($GET(^PS(51.24,+PSSPW4,0)),"^")
+10 SET PSSPW8=$LENGTH(PSSPW6)+$LENGTH(PSSPW7)
+11 IF ($Y+5)>IOSL
DO ZASK
IF PSSPWXEX
QUIT
IF PSSPW8<49
WRITE !?3,"NUMERIC DOSE: "_PSSPW6_" DOSE UNIT: "_PSSPW7
QUIT
+12 WRITE !?3,"NUMERIC DOSE: "_PSSPW6
+13 WRITE !?3,"DOSE UNIT: "_PSSPW7
+14 QUIT
+15 ;
+16 ;
DOSEADX ;New fields added with PSS*1*147
+1 NEW PSSPWX1,PSSPWX2,PSSPWX3,PSSPWX4,PSSPWX5,PSSPWX6,PSSPWX7,PSSPWX8
+2 SET PSSPWX7=""
+3 SET PSSPWX1=$GET(^PSDRUG(PSSDIEN,"DOS2",PSSLIEN,0))
+4 SET PSSPWX2=$PIECE(PSSPWX1,"^",3)
+5 SET PSSPWX3=$SELECT($EXTRACT(PSSPWX2)=".":"0",1:"")_PSSPWX2
+6 IF ($Y+5)>IOSL
DO XASK
IF PSSPWZEX
QUIT
WRITE !?3,"BCMA UNITS PER DOSE: "_PSSPWX3
+7 SET PSSPWX4=$PIECE(PSSPWX1,"^",5)
SET PSSPWX5=$PIECE(PSSPWX1,"^",6)
+8 SET PSSPWX6=$SELECT($EXTRACT(PSSPWX5)=".":"0",1:"")_PSSPWX5
+9 IF PSSPWX4
SET PSSPWX7=$PIECE($GET(^PS(51.24,+PSSPWX4,0)),"^")
+10 SET PSSPWX8=$LENGTH(PSSPWX6)+$LENGTH(PSSPWX7)
+11 IF ($Y+5)>IOSL
DO XASK
IF PSSPWZEX
QUIT
IF PSSPWX8<49
WRITE !?3,"NUMERIC DOSE: "_PSSPWX6_" DOSE UNIT: "_PSSPWX7
QUIT
+12 WRITE !?3,"NUMERIC DOSE: "_PSSPWX6
+13 WRITE !?3,"DOSE UNIT: "_PSSPWX7
+14 QUIT
+15 ;
+16 ;
ZASK ;Ask to continue
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 KILL DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to continue,'^' to exit the list"
DO ^DIR
KILL DIR
IF 'Y
SET PSSPWXEX=1
+3 WRITE @IOF
+4 QUIT
+5 ;
+6 ;
XASK ;Ask to continue
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 KILL DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to continue,'^' to exit the list"
DO ^DIR
KILL DIR
IF 'Y
SET PSSPWZEX=1
+3 WRITE @IOF
+4 QUIT
+5 ;
+6 ;
DASK ;Ask to continue
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 KILL DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+3 WRITE @IOF
+4 QUIT
