Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSSUTIL3

PSSUTIL3.m

Go to the documentation of this file.
  1. PSSUTIL3 ;BIR/SJA-utility routine for NDF changes ;07/09/10
  1. ;;1.0;PHARMACY DATA MANAGEMENT;**155**;9/30/97;Build 36
  1. ;
  1. EN2 N PSSPKG
  1. S PSSPKG=$P($$POSDOS^PSNAPIS(PSSND),"^",3)
  1. 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
  1. .S PSSTOT=1 F PSSDUPD=1,2 D
  1. ..I PSSUPRA="NO"&(PSSDUPD=2) Q
  1. ..S PSSTODOS=PSSDUPD*PSSST
  1. ..S ^PSDRUG(PSSDIEN,"DOS1",PSSTOT,0)=PSSDUPD_"^"_PSSTODOS_"^"_PSSPKG,^PSDRUG(PSSDIEN,"DOS1","B",PSSDUPD,PSSTOT)="" S PSSTOT=PSSTOT+1
  1. Q
  1. TEST ;
  1. K PSSNL,PSSNLF,PSSNLX
  1. Q:$G(PSNOUNPT)=""
  1. Q:$L(PSNOUNPT)'>3
  1. S PSSNL=$E(PSNOUNPT,($L(PSNOUNPT)-2),$L(PSNOUNPT))
  1. I $G(PSSNL)="(S)"!($G(PSSNL)="(s)") S PSSNLF=1 D
  1. .I $G(PSDUPDPT)'>1 S PSSNLX=$E(PSNOUNPT,1,($L(PSNOUNPT)-3))
  1. .I $G(PSDUPDPT)>1 S PSSNLX=$E(PSNOUNPT,1,($L(PSNOUNPT)-3))_$E(PSSNL,2)
  1. Q
  1. SUPRA(PSSND) ; set supra flag
  1. N PSSDOS,PSSCD,PSSDOSC,PSSPKG
  1. S PSSDOS=$$POSDOS^PSNAPIS(PSSND),PSSCD=$P(PSSDOS,"^"),PSSDOSC=$P(PSSDOS,"^",2),PSSPKG=$P(PSSDOS,"^",3)
  1. Q $S(PSSCD="N"&(PSSDOSC="O"):"NO",(PSSCD="N")&(PSSDOSC="B"):"NB",(PSSCD="N")&(PSSDOSC="N"):"NN",1:"")
  1. ;
  1. CHECK(PSSIEN) ; check if the drug meets the criteria to have Possible Dosages
  1. N PSSNAT,PSSNAT1,PSSNATND,PSSNATDF,PSSNATUN,PSSNATST
  1. D NATND
  1. I 'PSSNATDF!('PSSNATUN)!($G(PSSNATST)="") Q 0
  1. I '$D(^PS(50.606,PSSNATDF,0))!('$D(^PS(50.607,PSSNATUN,0))) Q 0
  1. I PSSNATST'?.N&(PSSNATST'?.N1".".N) Q 0
  1. I $D(^PS(50.606,"ACONI",PSSNATDF,PSSNATUN)),$O(^PS(50.606,"ADUPI",PSSNATDF,0)) Q 1
  1. I $D(^PS(50.606,"ACONO",PSSNATDF,PSSNATUN)),$O(^PS(50.606,"ADUPO",PSSNATDF,0)) Q 1
  1. Q 0
  1. NATND S PSSNAT=+$P($G(^PSDRUG(PSSIEN,"ND")),"^",3),PSSNAT1=$P($G(^("ND")),"^")
  1. S PSSNATND=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT)
  1. S PSSNATDF=$P(PSSNATND,"^"),PSSNATST=$P(PSSNATND,"^",4),PSSNATUN=$P(PSSNATND,"^",5)
  1. Q