PSSUTIL3 ;BIR/SJA-utility routine for NDF changes ;07/09/10
;;1.0;PHARMACY DATA MANAGEMENT;**155**;9/30/97;Build 36
;
EN2 N PSSPKG
S PSSPKG=$P($$POSDOS^PSNAPIS(PSSND),"^",3)
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) I '(PSSI&PSSO) G LOC^PSSUTIL
.S PSSTOT=1 F PSSDUPD=1,2 D
..I PSSUPRA="NO"&(PSSDUPD=2) Q
..S PSSTODOS=PSSDUPD*PSSST
..S ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^"_PSSPKG,^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)="" S PSSTOT=PSSTOT+1
Q
TEST ;
K PSSNL,PSSNLF,PSSNLX
Q:$G(PSNOUNPT)=""
Q:$L(PSNOUNPT)'>3
S PSSNL=$E(PSNOUNPT,($L(PSNOUNPT)-2),$L(PSNOUNPT))
I $G(PSSNL)="(S)"!($G(PSSNL)="(s)") S PSSNLF=1 D
.I $G(PSDUPDPT)'>1 S PSSNLX=$E(PSNOUNPT,1,($L(PSNOUNPT)-3))
.I $G(PSDUPDPT)>1 S PSSNLX=$E(PSNOUNPT,1,($L(PSNOUNPT)-3))_$E(PSSNL,2)
Q
SUPRA(PSSND) ; set supra flag
N PSSDOS,PSSCD,PSSDOSC,PSSPKG
S PSSDOS=$$POSDOS^PSNAPIS(PSSND),PSSCD=$P(PSSDOS,"^"),PSSDOSC=$P(PSSDOS,"^",2),PSSPKG=$P(PSSDOS,"^",3)
Q $S(PSSCD="N"&(PSSDOSC="O"):"NO",(PSSCD="N")&(PSSDOSC="B"):"NB",(PSSCD="N")&(PSSDOSC="N"):"NN",1:"")
;
CHECK(PSSIEN) ; check if the drug meets the criteria to have Possible Dosages
N PSSNAT,PSSNAT1,PSSNATND,PSSNATDF,PSSNATUN,PSSNATST
D NATND
I 'PSSNATDF!('PSSNATUN)!($G(PSSNATST)="") Q 0
I '$D(^PS(50.606,PSSNATDF,0))!('$D(^PS(50.607,PSSNATUN,0))) Q 0
I PSSNATST'?.N&(PSSNATST'?.N1".".N) Q 0
I $D(^PS(50.606,"ACONI",PSSNATDF,PSSNATUN)),$O(^PS(50.606,"ADUPI",PSSNATDF,0)) Q 1
I $D(^PS(50.606,"ACONO",PSSNATDF,PSSNATUN)),$O(^PS(50.606,"ADUPO",PSSNATDF,0)) Q 1
Q 0
NATND S PSSNAT=+$P($G(^PSDRUG(PSSIEN,"ND")),"^",3),PSSNAT1=$P($G(^("ND")),"^")
S PSSNATND=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT)
S PSSNATDF=$P(PSSNATND,"^"),PSSNATST=$P(PSSNATND,"^",4),PSSNATUN=$P(PSSNATND,"^",5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSUTIL3 1882 printed Apr 09, 2024@21:34:57 Page 2
PSSUTIL3 ;BIR/SJA-utility routine for NDF changes ;07/09/10
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**155**;9/30/97;Build 36
+2 ;
EN2 NEW PSSPKG
+1 SET PSSPKG=$PIECE($$POSDOS^PSNAPIS(PSSND),"^",3)
+2 Begin DoDot:1
+3 SET PSSTOT=1
FOR PSSDUPD=1,2
Begin DoDot:2
+4 IF PSSUPRA="NO"&(PSSDUPD=2)
QUIT
+5 SET PSSTODOS=PSSDUPD*PSSST
+6 SET ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^"_PSSPKG
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)
IF '(PSSI&PSSO)
GOTO LOC^PSSUTIL
+7 QUIT
TEST ;
+1 KILL PSSNL,PSSNLF,PSSNLX
+2 if $GET(PSNOUNPT)=""
QUIT
+3 if $LENGTH(PSNOUNPT)'>3
QUIT
+4 SET PSSNL=$EXTRACT(PSNOUNPT,($LENGTH(PSNOUNPT)-2),$LENGTH(PSNOUNPT))
+5 IF $GET(PSSNL)="(S)"!($GET(PSSNL)="(s)")
SET PSSNLF=1
Begin DoDot:1
+6 IF $GET(PSDUPDPT)'>1
SET PSSNLX=$EXTRACT(PSNOUNPT,1,($LENGTH(PSNOUNPT)-3))
+7 IF $GET(PSDUPDPT)>1
SET PSSNLX=$EXTRACT(PSNOUNPT,1,($LENGTH(PSNOUNPT)-3))_$EXTRACT(PSSNL,2)
End DoDot:1
+8 QUIT
SUPRA(PSSND) ; set supra flag
+1 NEW PSSDOS,PSSCD,PSSDOSC,PSSPKG
+2 SET PSSDOS=$$POSDOS^PSNAPIS(PSSND)
SET PSSCD=$PIECE(PSSDOS,"^")
SET PSSDOSC=$PIECE(PSSDOS,"^",2)
SET PSSPKG=$PIECE(PSSDOS,"^",3)
+3 QUIT $SELECT(PSSCD="N"&(PSSDOSC="O"):"NO",(PSSCD="N")&(PSSDOSC="B"):"NB",(PSSCD="N")&(PSSDOSC="N"):"NN",1:"")
+4 ;
CHECK(PSSIEN) ; check if the drug meets the criteria to have Possible Dosages
+1 NEW PSSNAT,PSSNAT1,PSSNATND,PSSNATDF,PSSNATUN,PSSNATST
+2 DO NATND
+3 IF 'PSSNATDF!('PSSNATUN)!($GET(PSSNATST)="")
QUIT 0
+4 IF '$DATA(^PS(50.606,PSSNATDF,0))!('$DATA(^PS(50.607,PSSNATUN,0)))
QUIT 0
+5 IF PSSNATST'?.N&(PSSNATST'?.N1".".N)
QUIT 0
+6 IF $DATA(^PS(50.606,"ACONI",PSSNATDF,PSSNATUN))
IF $ORDER(^PS(50.606,"ADUPI",PSSNATDF,0))
QUIT 1
+7 IF $DATA(^PS(50.606,"ACONO",PSSNATDF,PSSNATUN))
IF $ORDER(^PS(50.606,"ADUPO",PSSNATDF,0))
QUIT 1
+8 QUIT 0
NATND SET PSSNAT=+$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^",3)
SET PSSNAT1=$PIECE($GET(^("ND")),"^")
+1 SET PSSNATND=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT)
+2 SET PSSNATDF=$PIECE(PSSNATND,"^")
SET PSSNATST=$PIECE(PSSNATND,"^",4)
SET PSSNATUN=$PIECE(PSSNATND,"^",5)
+3 QUIT
