PSSDSUTL ;BIR/MV-Dose Check utility routine (continued) ;27 Oct 2009 12:22 PM
;;1.0;PHARMACY DATA MANAGEMENT;**201,178,206,224,231**;9/30/97;Build 4
;
RANGE ;Evaluate free text dosages for range patterns
N PSSRG1,PSSRG2,PSSRG3,PSSRG4,PSSRG5,PSSRG6,PSSRGAR,PSSRGDOS,PSSRGLT,PSSRGNM1,PSSRGNM2,PSSRGUN1,PSSRGUN2
S PSSRG2=0,PSSRGDOS=$G(PSSDSLCL)
S PSSRGDOS=$$UP^XLFSTR(PSSRGDOS)
S PSSRGLT=$L(PSSRGDOS) I PSSRGLT'>3!(PSSRGDOS[" ") Q
F PSSRG1=1:1:PSSRGLT Q:PSSRG2>4 I $E(PSSRGDOS,PSSRG1)=" " S PSSRG2=PSSRG2+1
I PSSRG2>4 Q
S PSSRGDOS=$TR(PSSRGDOS," ","") Q:$L(PSSRGDOS)'>0 ;Remove all spaces
;Derive leading numeric value
I $E(PSSRGDOS)'?1N,$E(PSSRGDOS)'?1"." Q
I $E(PSSRGDOS)?1".",$E(PSSRGDOS,2)'?1N Q
S PSSRG2=0 F PSSRG3=1:1:$L(PSSRGDOS) Q:PSSRG2 S PSSRG4=$E(PSSRGDOS,PSSRG3) I PSSRG4'?1N,PSSRG4'?1".",PSSRG4'?1"," S PSSRG2=PSSRG3
Q:'PSSRG2 ;only a numeric passed in
S PSSRGNM1=$E(PSSRGDOS,1,(PSSRG2-1)),PSSRGDOS=$E(PSSRGDOS,PSSRG2,$L(PSSRGDOS)) Q:$L(PSSRGDOS)'>2
S PSSRGAR=$E(PSSRGNM1,$L(PSSRGNM1)) I PSSRGAR="."!(PSSRGAR=",") Q
S PSSRG2=0 F PSSRG3=1:1:$L(PSSRGNM1) Q:PSSRG2>1 S PSSRG5=$E(PSSRGNM1,PSSRG3) S:PSSRG5="." PSSRG2=PSSRG2+1
Q:PSSRG2>1
S PSSRGNM1=$TR(PSSRGNM1,",","") ;PSSRGNM1 Set to first numeric
S (PSSRG2,PSSRG4,PSSRG5)=0 F PSSRG3=1:1:$L(PSSRGDOS) Q:PSSRG2 S PSSRG4=$E(PSSRGDOS,PSSRG3) D:'PSSRG5 I PSSRG5,PSSRG4'?1N,PSSRG4'?1",",PSSRG4'?1"." S PSSRG2=PSSRG3
.I PSSRG4?1N!(PSSRG4?1".") S (PSSRG5,PSSRG6)=PSSRG3
I 'PSSRG5 Q
I PSSRG2 S PSSRGUN2=$E(PSSRGDOS,PSSRG2,$L(PSSRGDOS)),PSSRGNM2=$E(PSSRGDOS,PSSRG5,(PSSRG2-1)) ;PSSRGUN2 set to second Unit if there is one
I 'PSSRG2 S PSSRGNM2=$E(PSSRGDOS,PSSRG5,$L(PSSRGDOS))
I $E(PSSRGNM2)'?1N,$E(PSSRGNM2)'?1"." Q
I $E(PSSRGNM2)?1".",$E(PSSRGNM2,2)'?1N Q
S PSSRGAR=$E(PSSRGNM2,$L(PSSRGNM2)) I PSSRGAR="."!(PSSRGAR=",") Q
S PSSRG2=0 F PSSRG3=1:1:$L(PSSRGNM2) Q:PSSRG2>1 S PSSRG5=$E(PSSRGNM2,PSSRG3) S:PSSRG5="." PSSRG2=PSSRG2+1
Q:PSSRG2>1
S PSSRGNM2=$TR(PSSRGNM2,",","") ;PSSRGNM2 Set to second numeric
S PSSRGDOS=$E(PSSRGDOS,1,(PSSRG6-1))
S PSSRG6=$L(PSSRGDOS) Q:PSSRG6'>0
S PSSRG1=$E(PSSRGDOS,PSSRG6)
I PSSRG1="-" S:PSSRG6>1 PSSRGUN1=$E(PSSRGDOS,1,(PSSRG6-1)) D RANGEOK Q
S PSSRG2=$E(PSSRGDOS,(PSSRG6-1),PSSRG6) I PSSRG2="TO"!(PSSRG2="OR") S:PSSRG6>2 PSSRGUN1=$E(PSSRGDOS,1,(PSSRG6-2)) D RANGEOK
Q
;
;
RANGEOK ;Retrieved all needed Dosing
N PSSRGUNA,PSSRGUNB
I PSSRGNM2'>PSSRGNM1 Q
I PSSDBIFL D Q
.I $G(PSSRGUN1)'="" S PSSRGUNA=$$UNITD^PSSDSAPI(PSSRGUN1)
.I $G(PSSRGUN2)'="" S PSSRGUNB=$$UNITD^PSSDSAPI(PSSRGUN2)
.I $G(PSSRGUN1)'="",$G(PSSRGUN2)'="" D Q
..I $G(PSSRGUNA)'="",PSSRGUNA=$G(PSSRGUNB) S PSSDBAR("AMN")=PSSRGNM2,PSSDBAR("UNIT")=PSSRGUNA,PSSDBFAL=1
.I $G(PSSRGUN1)="" D
..I $G(PSSRGUNB)'="" S PSSDBAR("AMN")=PSSRGNM2,PSSDBAR("UNIT")=PSSRGUNB,PSSDBFAL=1
.I $G(PSSRGUN2)="" D
..I $G(PSSRGUNA)'="" S PSSDBAR("AMN")=PSSRGNM2,PSSDBAR("UNIT")=PSSRGUNA,PSSDBFAL=1
I $G(PSSRGUN1)'="" S PSSRGUNA=$$UNIT^PSSDSAPI(PSSRGUN1)
I $G(PSSRGUN2)'="" S PSSRGUNB=$$UNIT^PSSDSAPI(PSSRGUN2)
I $G(PSSRGUN1)'="",$G(PSSRGUN2)'="" D Q
.I $G(PSSRGUNA)'="",PSSRGUNA=$G(PSSRGUNB) S PSSDBAR("AMN")=PSSRGNM2,PSSDBAR("UNIT")=PSSRGUNA,PSSDBFAL=1
I $G(PSSRGUN1)="" D
.I $G(PSSRGUNB)'="" S PSSDBAR("AMN")=PSSRGNM2,PSSDBAR("UNIT")=PSSRGUNB,PSSDBFAL=1
I $G(PSSRGUN2)="" D
.I $G(PSSRGUNA)'="" S PSSDBAR("AMN")=PSSRGNM2,PSSDBAR("UNIT")=PSSRGUNA,PSSDBFAL=1
Q
;
;
MLTOK(PSSUTM1,PSSUTM3) ;If multi ingredient, and all ingredients in VA Product have a Unit and it matches the unit from the order
N DA,PSSUTMCT,PSSUTMLP,PSSUTMUX,PSSUTMAR,PSSUTMQT,PSSUTMUZ
S PSSUTMQT=0
S PSSUTMCT=$$PSJING^PSNAPIS(PSSUTM1,PSSUTM3,.PSSUTMAR) I $G(PSSUTMCT)'>1 Q 1
F PSSUTMLP=0:0 S PSSUTMLP=$O(PSSUTMAR(PSSUTMLP)) Q:'PSSUTMLP!(PSSUTMQT) D
.S PSSUTMUX=$P(PSSUTMAR(PSSUTMLP),"^",4) I PSSUTMUX="" S PSSUTMQT=1 Q
.S PSSUTMUZ=$$UNITD^PSSDSAPI(PSSUTMUX) I PSSUTMUZ="" S PSSUTMQT=1 Q
.I PSSUTMUZ'=PSSDBAR("UNIT") S PSSUTMQT=1
Q PSSUTMQT
;
;
UPCPRS ;Update CPRS global
I '$D(^TMP($J,PSSDBASF)) Q
N PSSCPC5,PSSCPC6,PSSCPC7,PSSCPC8,PSSCPC9,PSSCPCNM,PSSCPGL,PSSCPCND,PSSCPCNN,PSSCPCAR,PSSCPCNX,PSSCPCO1,PSSCPCO2,PSSCPCO3,PSSCPCG1,PSSCPCGN,PSSCPCWA,PSSCPBMR,PSSCPCAJ,PSSCPCAC,PSSCPCE1,PSSCPCE2,PSSCPCR1,PSSCPCR2
N PSSCPCR3,PSSCPCR4,PSSCPCR5,PSSCPCR6
K ^TMP($J,"PSSCPNEW") M ^TMP($J,"PSSCPNEW")=^TMP($J,PSSDBASF) K ^TMP($J,PSSDBASF)
S PSSCPCGL="PSSCPNEW"
;
;Errors - remove Dose subscript, and piece 27 check to to see any error should be kept
S PSSCPC5="" F S PSSCPC5=$O(PSSDBCAR(PSSCPC5)) Q:PSSCPC5="" S PSSCPCWA=0 D:'$P(PSSDBCAR(PSSCPC5),"^",14)
.S PSSCPCR1=0,(PSSCPCR2,PSSCPCR5)=1,PSSCPC6="" F S PSSCPC6=$O(^TMP($J,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6)) Q:PSSCPC6="" S PSSCPCNM=$P(PSSCPC5,";",4) D
..S PSSCPCE1=$G(^TMP($J,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6,"MSG"))
..S PSSCPCE2=$G(^TMP($J,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6,"TEXT"))
..I $G(^TMP($J,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6,"WARN"))="Warning",'$P(PSSCPC5,";",5) S $P(PSSDBCAR(PSSCPC5),"^",13)="",PSSCPCWA=1 D Q
...S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,1,"ATYPE")="DOSE^EXCEPTION"
...S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,1,"MSG",1)=PSSCPCE1_$S($E(PSSCPCE1,$L(PSSCPCE1))'=":":":",1:"")_" "_PSSCPCE2
..I '$P(PSSDBCAR(PSSCPC5),"^",27) Q
..I '$O(^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,""))!(PSSCPCR1) D Q
...S PSSCPCR1=1
...S ^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR2)=PSSCPCE1_$S($E(PSSCPCE1,$L(PSSCPCE1))'=".":".",1:"")_" "_PSSCPCE2,PSSCPCR2=PSSCPCR2+1
..I PSSCPCR5=1 K PSSCPCR3 S PSSCPCR4="" F S PSSCPCR4=$O(^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR4)) Q:PSSCPCR4="" D
...S PSSCPCR3(PSSCPCR4)=^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR4) K ^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR4)
..S ^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR5)=PSSCPCE1_$S($E(PSSCPCE1,$L(PSSCPCE1))'=".":".",1:"")_" "_PSSCPCE2,PSSCPCR5=PSSCPCR5+1
.I $O(PSSCPCR3("")) S PSSCPCR6="" F S PSSCPCR6=$O(PSSCPCR3(PSSCPCR6)) Q:PSSCPCR6="" D
..S ^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR5)=PSSCPCR3(PSSCPCR6),PSSCPCR5=PSSCPCR5+1
.;
.Q:PSSCPCWA ;Quit if warning
.S PSSCPCAR(PSSCPC5)=1 S PSSCPCNM=$P(PSSCPC5,";",4) I $P(PSSDBCAR(PSSCPC5),"^",27) D
..S PSSCPC6="" F S PSSCPC6=$O(^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPC6)) Q:PSSCPC6="" D
...S PSSCPCND=$G(^TMP($J,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPC6)) Q:PSSCPCND=""
...S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^EXCEPTION"
...S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=PSSCPCND,PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
.;Set generic exception if needed
.I '$P(PSSDBCAR(PSSCPC5),"^",27),('$G(PSSENHK(PSSCPC5))!('$G(PSSENHKZ(PSSCPC5)))) D
..;I $P(PSSDBCAR(PSSCPC5),"^",29) S $P(PSSDBCAR(PSSCPC5),"^",4)=0 ;need this to show Daily Dose error
..I '$D(PSSDSDPL(PSSCPC5))!($P(PSSDBCAR(PSSCPC5),"^",4)&('$P(PSSDBCAR(PSSCPC5),"^",13))) Q
..S PSSCPCG1="" I '$P(PSSDBCAR(PSSCPC5),"^",13),'$P(PSSDBCAR(PSSCPC5),"^",4) S PSSCPCG1="Max Daily Dose Check"
..I '$P(PSSDBCAR(PSSCPC5),"^",13),PSSCPCG1="" Q
..I PSSCPCG1'="",$P(PSSDBCAR(PSSCPC5),"^",15)!($P(PSSDBCAR(PSSCPC5),"^",16))!($P(PSSCPC5,";",5)) K PSSCPCG1 Q
..I PSSCPCG1="" S PSSCPCG1=$S('$P(PSSDBCAR(PSSCPC5),"^",15)&('$P(PSSDBCAR(PSSCPC5),"^",16)):"Dosing Checks",1:"Maximum Single Dose Check")
..S PSSCPBMR=$S($P(PSSDBCAR(PSSCPC5),"^",31):$E($P(PSSDBCAR(PSSCPC5),"^",32),1,($L($P(PSSDBCAR(PSSCPC5),"^",32))-2)),1:"")_$S($P(PSSDBCAR(PSSCPC5),"^",16):" (Dose="_$G(PSSDSDPL(PSSCPC5))_")",1:"")
..S PSSCPCGN=PSSCPCG1_" could not be done for Drug: "_$P(PSSDBCAR(PSSCPC5),"^",2)_PSSCPBMR
..S PSSCPCGN=PSSCPCGN_", please complete a manual check for appropriate Dosing."
..S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^EXCEPTION"
..S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=PSSCPCGN,PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
.;
.K PSSCPCAJ S PSSCPCO2="",(PSSCPCO3,PSSCPCAC)=0 S PSSCPC6="" F S PSSCPC6=$O(^TMP($J,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6)) Q:PSSCPC6="" D
..D PEROR S PSSCPCNM=$P(PSSCPC5,";",4) S PSSCPC7="" F S PSSCPC7=$O(^TMP($J,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7)) Q:PSSCPC7="" D
...I +PSSCPC7=2,$P(PSSDBCAR(PSSCPC5),"^",15)!($P(PSSDBCAR(PSSCPC5),"^",16))!($P(PSSCPC5,";",5)) Q ;2.1 added the conditions
...S PSSCPC8="" F S PSSCPC8=$O(^TMP($J,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8)) Q:PSSCPC8="" D
....I PSSCPCO2'="" D
.....S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^"_$S(+PSSCPC7=1:"SINGLE",+PSSCPC7=2:"DAILY",1:"GENERAL")
.....S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=PSSCPCO2
....I +PSSCPC7'=3 S PSSCPCNN=$S(PSSCPCO3:2,1:1) D:$G(PSSDBADJ(PSSCPC5))'=""&($G(PSSCPCAJ(PSSCPC5))="") SADJ D Q
.....S PSSCPCND=^TMP($J,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8) I PSSCPCAC S PSSCPCND=PSSCPCND_PSSCPCAJ(PSSCPC5)
.....I PSSCPCNN=1 S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^"_$S(+PSSCPC7=1:"SINGLE",1:"DAILY")
.....S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",PSSCPCNN)=PSSCPCND,PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
....S PSSCPCNN=$S(PSSCPCO3:1,1:0),PSSCPCAA=$S(PSSCPCNN:2,1:1)
....S PSSCPC9="" F S PSSCPC9=$O(^TMP($J,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8,PSSCPC9)) Q:PSSCPC9="" D
.....I 'PSSCPCNN S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^GENERAL"
.....S PSSCPCND=^TMP($J,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8,PSSCPC9)
.....S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",PSSCPCAA)=PSSCPCND,PSSCPCAA=PSSCPCAA+1,PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
.I $P(PSSDBCAR(PSSCPC5),"^",29) D CFREQ
K ^TMP($J,PSSCPCGL)
Q
;
;
CFREQ ;Add customized Frequency
I $P(PSSDBCAR(PSSCPC5),"^",15)!($P(PSSDBCAR(PSSCPC5),"^",16))!($P(PSSCPC5,";",5)) Q
S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^INFORMATIONAL"
S ^TMP($J,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=$G(^TMP($J,PSSDBASE,"OUT","DOSE",PSSCPC5,$P(PSSDBCAR(PSSCPC5),"^",2),"FREQ","FREQUENCYCUSTOMMESSAGE",$P(PSSDBCAR(PSSCPC5),"^",3)))
Q
;
;
PEROR ;Per Orifice check
N PSSCPCO9
S PSSCPCO9=$P(PSSDBCAR(PSSCPC5),"^",9) I PSSCPCO9="OTIC"!(PSSCPCO9="OPHTHALMIC")!(PSSCPCO9="INTRANASAL") D
.S PSSCPCO2="Dosing Information provided is PER "_$S(PSSCPCO9="OTIC":"EAR:",PSSCPCO9="OPHTHALMIC":"EYE:",1:"NOSTRIL:"),PSSCPCO3=1
Q
;
;
SADJ ;Parse out Adjusted Frequency message
N PSSSDADJ
S PSSCPCAC=1
S PSSSDADJ=$F(PSSDBADJ(PSSCPC5),"(") I 'PSSSDADJ S PSSCPCAJ(PSSCPC5)=" "_PSSDBADJ(PSSCPC5) Q
S PSSCPCAJ(PSSCPC5)=" "_$E(PSSDBADJ(PSSCPC5),(PSSSDADJ-1),$L(PSSDBADJ(PSSCPC5))-1)
Q
;
;
PTH ;Local Dosage with parenthesis, extract data from before and within
N PSSPTH1,PSSPTH2,PSSPTH3,PSSPTH4,PSSPTHL,PSSPTHA,PSSPTHC,PSSPTHF,PSSPTHD,PSSPTHS1,PSSPTHS2,PSSPTHS3,PSSPTHS4
K PSSDSLC1 S (PSSPTH1,PSSPTH2,PSSPTH3,PSSPTH4,PSSPTHF)=0,PSSPTHD=PSSDSLCL
S PSSPTHL=$L(PSSPTHD)
F PSSPTHA=1:1:PSSPTHL Q:PSSPTHF S PSSPTHC=$E(PSSPTHD,PSSPTHA) D
.I PSSPTHC'="(",PSSPTHC'=")" Q
.I PSSPTHC="(" S PSSPTH1=PSSPTHA,PSSPTH3=PSSPTH3+1 S:PSSPTH3>1 PSSPTHF=1 Q
.S PSSPTH2=PSSPTHA,PSSPTH4=PSSPTH4+1 S:PSSPTH4>1 PSSPTHF=1 Q
Q:PSSPTHF ;Quit if more than 1 of either parenthesis
Q:'PSSPTH3!('PSSPTH4) ;Quit if either parenthesis is missing
Q:PSSPTH1'<PSSPTH2 ;Quit if left paren is not before right paren
I PSSPTH1>1 S PSSPTHS1="" D I PSSPTHS1'="" S PSSDSLC1(2)=PSSPTHS1,PSSDSLCT=2
.S PSSPTHS1=$E(PSSPTHD,1,(PSSPTH1-1)),PSSPTHS2=$L(PSSPTHS1),PSSPTHS4=0
.F PSSPTHS3=PSSPTHS2:-1:1 I $E(PSSPTHS1,PSSPTHS3)'=" " S PSSPTHS4=PSSPTHS3 Q
.Q:PSSPTHS4=PSSPTHS2
.I 'PSSPTHS4 S PSSPTHS1="" Q
.S PSSPTHS1=$E(PSSPTHS1,1,PSSPTHS4)
I (PSSPTH1+1)'<PSSPTH2 D:PSSDSLCT Q
.S PSSDSLC1(1)=PSSDSLC1(2),PSSDSLCT=1 K PSSDSLC1(2)
S PSSDSLC1(1)=$E(PSSPTHD,(PSSPTH1+1),(PSSPTH2-1)) I 'PSSDSLCT S PSSDSLCT=1
Q
;
;
RTEXT(PSSBAMRT,PSSBSPC) ;Set Reason Header
N PSSBSPCS S PSSBSPCS=$S(PSSBSPC:" ",1:"")
S PSSDWRSN=$S('$P(PSSDBCAR(PSSBAMRT),"^",31):PSSBSPCS_"Reason(s): ",1:PSSBSPCS_"Reason(s)"_$P(PSSDBCAR(PSSBAMRT),"^",32))
Q
;
;
ORDFREQ(PSSDADF) ; -- in 2.1 get order frequency by converting FDB frequency patterns -- called from PSSHRQ23
;PSSDADF - Frequency # or Pattern
;
;Return: Order Frequency or 0
;
N PSSDADL,PSSDADN,PSSDADTM,PSSDADS
; -- check for missing variable, exit if not defined
I $G(PSSDADF)']"" Q 0
; -- check for number
I $G(PSSDADF) Q $G(PSSDADF)
; -- every other day
I PSSDADF="QOD" Q .5
; -- set PSSDADL=Frequency Length, exit if not equal to 3 or 4
S PSSDADL=$L(PSSDADF) I PSSDADL'=3,PSSDADL'=4 Q 0
; -- set PSSDADS=Action associated with frequency Q=every, X=times
S PSSDADS=$E(PSSDADF)
; -- check action associated with frequency, exit if not "Q" or "X"
I PSSDADS'="Q",PSSDADS'="X" Q 0
; -- set PSSDADN=Frequency Number
S PSSDADN=$E(PSSDADF,2,$L(PSSDADF)-1)
; -- check if PSSDADN is numeric, exit if it is not
I PSSDADN'?.N Q 0
; -- set PSSDADTM=period of time associated with frequency H=hour, D=day, W=week, L=month
S PSSDADTM=$E(PSSDADF,PSSDADL)
; -- calculate order frequency every # hour(s)
I PSSDADS="Q",PSSDADTM="H" Q 24/PSSDADN
; -- calculate order frequency every # days(s)
I PSSDADS="Q",PSSDADTM="D" Q 1/PSSDADN
; -- calculate order frequency every # week(s)
I PSSDADS="Q",PSSDADTM="W" Q 1/(PSSDADN*7)
; -- calculate order frequency every # month(s)
I PSSDADS="Q",PSSDADTM="L" Q 1/(PSSDADN*30)
; -- calculate order frequency # times per day
I PSSDADS="X",PSSDADTM="D" Q PSSDADN
; -- calculate order frequency # times per week
I PSSDADS="X",PSSDADTM="W" Q PSSDADN/7
; -- calculate order frequency # times per month
I PSSDADS="X",PSSDADTM="L" Q PSSDADN/30
Q 0
;
;
ROUNDNUM(X) ; -- in 2.1 if number is < or = 1, round to 4 decimals otherwise no decimals -- called from PSSHRQ23
;X - Number
;
;Return: Rounded Number or 0
N N,ND
; -- check for missing variable, exit if not defined
I $G(X)'>0 Q 0
; -- get number of decimals
S ND=$L($P(+X,".",2))
; -- set number Of decimals
S N=$S(+X>1:0,1:4)
; -- if number is zero, round up until number is nolonger zero
I $J(+X,"",N)'>0 D
. F N=1:1:ND Q:$J(X,"",N)>0
Q +$J(X,"",N)
;
;
PRNSCHD(PSSSCHD) ;If 'PRN' appended to the schedule, return the schedule with 'PRN' remove
NEW PSSXL,PSSXSCHD,PSSXSCHN
I $G(PSSSCHD)="" Q ""
I $D(^PS(51.1,"APPSJ",PSSSCHD)) Q PSSSCHD
S PSSXL=$L(PSSSCHD)
I $E(PSSSCHD,(PSSXL-2),PSSXL)="PRN" D ;Check name cross-index
. S PSSXSCHD=$E(PSSSCHD,1,(PSSXL-4))
. I (PSSXSCHD'=""),(PSSXSCHD'?." ") S:$D(^PS(51.1,"APPSJ",PSSXSCHD)) PSSSCHD=PSSXSCHD
I $E(PSSSCHD,(PSSXL-2),PSSXL)="PRN" D ;Check Old Schedule Name(s) cross-index PSS*1*231
. S PSSXSCHD=$E(PSSSCHD,1,(PSSXL-4))
. I (PSSXSCHD'=""),(PSSXSCHD'?." "),$D(^PS(51.1,"D",PSSXSCHD)) S PSSXSCHN=$O(^PS(51.1,"D",PSSXSCHD,0)),PSSSCHD=$P($G(^PS(51.1,PSSXSCHN,0)),U,1)
Q PSSSCHD
;
;
PRNMI(PSSMI) ;If 'PRN' appended to the Med instruction, return the MI with 'PRN' remove
NEW PSSXL,PSSXMI
I $G(PSSMI)="" Q ""
I $D(^PS(51,"B",PSSMI)) Q PSSMI
S PSSXL=$L(PSSMI)
I $E(PSSMI,(PSSXL-2),PSSXL)="PRN" D
. S PSSXMI=$E(PSSMI,1,(PSSXL-4))
. I (PSSXMI'=""),(PSSXMI'?." ") S:$D(^PS(51,"B",PSSXMI)) PSSMI=PSSXMI
Q PSSMI
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDSUTL 15724 printed Jan 18, 2025@03:32:06 Page 2
PSSDSUTL ;BIR/MV-Dose Check utility routine (continued) ;27 Oct 2009 12:22 PM
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**201,178,206,224,231**;9/30/97;Build 4
+2 ;
RANGE ;Evaluate free text dosages for range patterns
+1 NEW PSSRG1,PSSRG2,PSSRG3,PSSRG4,PSSRG5,PSSRG6,PSSRGAR,PSSRGDOS,PSSRGLT,PSSRGNM1,PSSRGNM2,PSSRGUN1,PSSRGUN2
+2 SET PSSRG2=0
SET PSSRGDOS=$GET(PSSDSLCL)
+3 SET PSSRGDOS=$$UP^XLFSTR(PSSRGDOS)
+4 SET PSSRGLT=$LENGTH(PSSRGDOS)
IF PSSRGLT'>3!(PSSRGDOS[" ")
QUIT
+5 FOR PSSRG1=1:1:PSSRGLT
if PSSRG2>4
QUIT
IF $EXTRACT(PSSRGDOS,PSSRG1)=" "
SET PSSRG2=PSSRG2+1
+6 IF PSSRG2>4
QUIT
+7 ;Remove all spaces
SET PSSRGDOS=$TRANSLATE(PSSRGDOS," ","")
if $LENGTH(PSSRGDOS)'>0
QUIT
+8 ;Derive leading numeric value
+9 IF $EXTRACT(PSSRGDOS)'?1N
IF $EXTRACT(PSSRGDOS)'?1"."
QUIT
+10 IF $EXTRACT(PSSRGDOS)?1"."
IF $EXTRACT(PSSRGDOS,2)'?1N
QUIT
+11 SET PSSRG2=0
FOR PSSRG3=1:1:$LENGTH(PSSRGDOS)
if PSSRG2
QUIT
SET PSSRG4=$EXTRACT(PSSRGDOS,PSSRG3)
IF PSSRG4'?1N
IF PSSRG4'?1"."
IF PSSRG4'?1","
SET PSSRG2=PSSRG3
+12 ;only a numeric passed in
if 'PSSRG2
QUIT
+13 SET PSSRGNM1=$EXTRACT(PSSRGDOS,1,(PSSRG2-1))
SET PSSRGDOS=$EXTRACT(PSSRGDOS,PSSRG2,$LENGTH(PSSRGDOS))
if $LENGTH(PSSRGDOS)'>2
QUIT
+14 SET PSSRGAR=$EXTRACT(PSSRGNM1,$LENGTH(PSSRGNM1))
IF PSSRGAR="."!(PSSRGAR=",")
QUIT
+15 SET PSSRG2=0
FOR PSSRG3=1:1:$LENGTH(PSSRGNM1)
if PSSRG2>1
QUIT
SET PSSRG5=$EXTRACT(PSSRGNM1,PSSRG3)
if PSSRG5="."
SET PSSRG2=PSSRG2+1
+16 if PSSRG2>1
QUIT
+17 ;PSSRGNM1 Set to first numeric
SET PSSRGNM1=$TRANSLATE(PSSRGNM1,",","")
+18 SET (PSSRG2,PSSRG4,PSSRG5)=0
FOR PSSRG3=1:1:$LENGTH(PSSRGDOS)
if PSSRG2
QUIT
SET PSSRG4=$EXTRACT(PSSRGDOS,PSSRG3)
if 'PSSRG5
Begin DoDot:1
+19 IF PSSRG4?1N!(PSSRG4?1".")
SET (PSSRG5,PSSRG6)=PSSRG3
End DoDot:1
IF PSSRG5
IF PSSRG4'?1N
IF PSSRG4'?1","
IF PSSRG4'?1"."
SET PSSRG2=PSSRG3
+20 IF 'PSSRG5
QUIT
+21 ;PSSRGUN2 set to second Unit if there is one
IF PSSRG2
SET PSSRGUN2=$EXTRACT(PSSRGDOS,PSSRG2,$LENGTH(PSSRGDOS))
SET PSSRGNM2=$EXTRACT(PSSRGDOS,PSSRG5,(PSSRG2-1))
+22 IF 'PSSRG2
SET PSSRGNM2=$EXTRACT(PSSRGDOS,PSSRG5,$LENGTH(PSSRGDOS))
+23 IF $EXTRACT(PSSRGNM2)'?1N
IF $EXTRACT(PSSRGNM2)'?1"."
QUIT
+24 IF $EXTRACT(PSSRGNM2)?1"."
IF $EXTRACT(PSSRGNM2,2)'?1N
QUIT
+25 SET PSSRGAR=$EXTRACT(PSSRGNM2,$LENGTH(PSSRGNM2))
IF PSSRGAR="."!(PSSRGAR=",")
QUIT
+26 SET PSSRG2=0
FOR PSSRG3=1:1:$LENGTH(PSSRGNM2)
if PSSRG2>1
QUIT
SET PSSRG5=$EXTRACT(PSSRGNM2,PSSRG3)
if PSSRG5="."
SET PSSRG2=PSSRG2+1
+27 if PSSRG2>1
QUIT
+28 ;PSSRGNM2 Set to second numeric
SET PSSRGNM2=$TRANSLATE(PSSRGNM2,",","")
+29 SET PSSRGDOS=$EXTRACT(PSSRGDOS,1,(PSSRG6-1))
+30 SET PSSRG6=$LENGTH(PSSRGDOS)
if PSSRG6'>0
QUIT
+31 SET PSSRG1=$EXTRACT(PSSRGDOS,PSSRG6)
+32 IF PSSRG1="-"
if PSSRG6>1
SET PSSRGUN1=$EXTRACT(PSSRGDOS,1,(PSSRG6-1))
DO RANGEOK
QUIT
+33 SET PSSRG2=$EXTRACT(PSSRGDOS,(PSSRG6-1),PSSRG6)
IF PSSRG2="TO"!(PSSRG2="OR")
if PSSRG6>2
SET PSSRGUN1=$EXTRACT(PSSRGDOS,1,(PSSRG6-2))
DO RANGEOK
+34 QUIT
+35 ;
+36 ;
RANGEOK ;Retrieved all needed Dosing
+1 NEW PSSRGUNA,PSSRGUNB
+2 IF PSSRGNM2'>PSSRGNM1
QUIT
+3 IF PSSDBIFL
Begin DoDot:1
+4 IF $GET(PSSRGUN1)'=""
SET PSSRGUNA=$$UNITD^PSSDSAPI(PSSRGUN1)
+5 IF $GET(PSSRGUN2)'=""
SET PSSRGUNB=$$UNITD^PSSDSAPI(PSSRGUN2)
+6 IF $GET(PSSRGUN1)'=""
IF $GET(PSSRGUN2)'=""
Begin DoDot:2
+7 IF $GET(PSSRGUNA)'=""
IF PSSRGUNA=$GET(PSSRGUNB)
SET PSSDBAR("AMN")=PSSRGNM2
SET PSSDBAR("UNIT")=PSSRGUNA
SET PSSDBFAL=1
End DoDot:2
QUIT
+8 IF $GET(PSSRGUN1)=""
Begin DoDot:2
+9 IF $GET(PSSRGUNB)'=""
SET PSSDBAR("AMN")=PSSRGNM2
SET PSSDBAR("UNIT")=PSSRGUNB
SET PSSDBFAL=1
End DoDot:2
+10 IF $GET(PSSRGUN2)=""
Begin DoDot:2
+11 IF $GET(PSSRGUNA)'=""
SET PSSDBAR("AMN")=PSSRGNM2
SET PSSDBAR("UNIT")=PSSRGUNA
SET PSSDBFAL=1
End DoDot:2
End DoDot:1
QUIT
+12 IF $GET(PSSRGUN1)'=""
SET PSSRGUNA=$$UNIT^PSSDSAPI(PSSRGUN1)
+13 IF $GET(PSSRGUN2)'=""
SET PSSRGUNB=$$UNIT^PSSDSAPI(PSSRGUN2)
+14 IF $GET(PSSRGUN1)'=""
IF $GET(PSSRGUN2)'=""
Begin DoDot:1
+15 IF $GET(PSSRGUNA)'=""
IF PSSRGUNA=$GET(PSSRGUNB)
SET PSSDBAR("AMN")=PSSRGNM2
SET PSSDBAR("UNIT")=PSSRGUNA
SET PSSDBFAL=1
End DoDot:1
QUIT
+16 IF $GET(PSSRGUN1)=""
Begin DoDot:1
+17 IF $GET(PSSRGUNB)'=""
SET PSSDBAR("AMN")=PSSRGNM2
SET PSSDBAR("UNIT")=PSSRGUNB
SET PSSDBFAL=1
End DoDot:1
+18 IF $GET(PSSRGUN2)=""
Begin DoDot:1
+19 IF $GET(PSSRGUNA)'=""
SET PSSDBAR("AMN")=PSSRGNM2
SET PSSDBAR("UNIT")=PSSRGUNA
SET PSSDBFAL=1
End DoDot:1
+20 QUIT
+21 ;
+22 ;
MLTOK(PSSUTM1,PSSUTM3) ;If multi ingredient, and all ingredients in VA Product have a Unit and it matches the unit from the order
+1 NEW DA,PSSUTMCT,PSSUTMLP,PSSUTMUX,PSSUTMAR,PSSUTMQT,PSSUTMUZ
+2 SET PSSUTMQT=0
+3 SET PSSUTMCT=$$PSJING^PSNAPIS(PSSUTM1,PSSUTM3,.PSSUTMAR)
IF $GET(PSSUTMCT)'>1
QUIT 1
+4 FOR PSSUTMLP=0:0
SET PSSUTMLP=$ORDER(PSSUTMAR(PSSUTMLP))
if 'PSSUTMLP!(PSSUTMQT)
QUIT
Begin DoDot:1
+5 SET PSSUTMUX=$PIECE(PSSUTMAR(PSSUTMLP),"^",4)
IF PSSUTMUX=""
SET PSSUTMQT=1
QUIT
+6 SET PSSUTMUZ=$$UNITD^PSSDSAPI(PSSUTMUX)
IF PSSUTMUZ=""
SET PSSUTMQT=1
QUIT
+7 IF PSSUTMUZ'=PSSDBAR("UNIT")
SET PSSUTMQT=1
End DoDot:1
+8 QUIT PSSUTMQT
+9 ;
+10 ;
UPCPRS ;Update CPRS global
+1 IF '$DATA(^TMP($JOB,PSSDBASF))
QUIT
+2 NEW PSSCPC5,PSSCPC6,PSSCPC7,PSSCPC8,PSSCPC9,PSSCPCNM,PSSCPGL,PSSCPCND,PSSCPCNN,PSSCPCAR,PSSCPCNX,PSSCPCO1,PSSCPCO2,PSSCPCO3,PSSCPCG1,PSSCPCGN,PSSCPCWA,PSSCPBMR,PSSCPCAJ,PSSCPCAC,PSSCPCE1,PSSCPCE2,PSSCPCR1,PSSCPCR2
+3 NEW PSSCPCR3,PSSCPCR4,PSSCPCR5,PSSCPCR6
+4 KILL ^TMP($JOB,"PSSCPNEW")
MERGE ^TMP($JOB,"PSSCPNEW")=^TMP($JOB,PSSDBASF)
KILL ^TMP($JOB,PSSDBASF)
+5 SET PSSCPCGL="PSSCPNEW"
+6 ;
+7 ;Errors - remove Dose subscript, and piece 27 check to to see any error should be kept
+8 SET PSSCPC5=""
FOR
SET PSSCPC5=$ORDER(PSSDBCAR(PSSCPC5))
if PSSCPC5=""
QUIT
SET PSSCPCWA=0
if '$PIECE(PSSDBCAR(PSSCPC5),"^",14)
Begin DoDot:1
+9 SET PSSCPCR1=0
SET (PSSCPCR2,PSSCPCR5)=1
SET PSSCPC6=""
FOR
SET PSSCPC6=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6))
if PSSCPC6=""
QUIT
SET PSSCPCNM=$PIECE(PSSCPC5,";",4)
Begin DoDot:2
+10 SET PSSCPCE1=$GET(^TMP($JOB,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6,"MSG"))
+11 SET PSSCPCE2=$GET(^TMP($JOB,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6,"TEXT"))
+12 IF $GET(^TMP($JOB,PSSCPCGL,"OUT","DOSE","ERROR",PSSCPC5,PSSCPC6,"WARN"))="Warning"
IF '$PIECE(PSSCPC5,";",5)
SET $PIECE(PSSDBCAR(PSSCPC5),"^",13)=""
SET PSSCPCWA=1
Begin DoDot:3
+13 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,1,"ATYPE")="DOSE^EXCEPTION"
+14 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,1,"MSG",1)=PSSCPCE1_$SELECT($EXTRACT(PSSCPCE1,$LENGTH(PSSCPCE1))'=":":":",1:"")_" "_PSSCPCE2
End DoDot:3
QUIT
+15 IF '$PIECE(PSSDBCAR(PSSCPC5),"^",27)
QUIT
+16 IF '$ORDER(^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,""))!(PSSCPCR1)
Begin DoDot:3
+17 SET PSSCPCR1=1
+18 SET ^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR2)=PSSCPCE1_$SELECT($EXTRACT(PSSCPCE1,$LENGTH(PSSCPCE1))'=".":".",1:"")_" "_PSSCPCE2
SET PSSCPCR2=PSSCPCR2+1
End DoDot:3
QUIT
+19 IF PSSCPCR5=1
KILL PSSCPCR3
SET PSSCPCR4=""
FOR
SET PSSCPCR4=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR4))
if PSSCPCR4=""
QUIT
Begin DoDot:3
+20 SET PSSCPCR3(PSSCPCR4)=^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR4)
KILL ^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR4)
End DoDot:3
+21 SET ^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR5)=PSSCPCE1_$SELECT($EXTRACT(PSSCPCE1,$LENGTH(PSSCPCE1))'=".":".",1:"")_" "_PSSCPCE2
SET PSSCPCR5=PSSCPCR5+1
End DoDot:2
+22 IF $ORDER(PSSCPCR3(""))
SET PSSCPCR6=""
FOR
SET PSSCPCR6=$ORDER(PSSCPCR3(PSSCPCR6))
if PSSCPCR6=""
QUIT
Begin DoDot:2
+23 SET ^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPCR5)=PSSCPCR3(PSSCPCR6)
SET PSSCPCR5=PSSCPCR5+1
End DoDot:2
+24 ;
+25 ;Quit if warning
if PSSCPCWA
QUIT
+26 SET PSSCPCAR(PSSCPC5)=1
SET PSSCPCNM=$PIECE(PSSCPC5,";",4)
IF $PIECE(PSSDBCAR(PSSCPC5),"^",27)
Begin DoDot:2
+27 SET PSSCPC6=""
FOR
SET PSSCPC6=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPC6))
if PSSCPC6=""
QUIT
Begin DoDot:3
+28 SET PSSCPCND=$GET(^TMP($JOB,PSSCPCGL,"OUT","EXCEPTIONS","DOSE",PSSCPC5,PSSCPC6))
if PSSCPCND=""
QUIT
+29 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^EXCEPTION"
+30 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=PSSCPCND
SET PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
End DoDot:3
End DoDot:2
+31 ;Set generic exception if needed
+32 IF '$PIECE(PSSDBCAR(PSSCPC5),"^",27)
IF ('$GET(PSSENHK(PSSCPC5))!('$GET(PSSENHKZ(PSSCPC5))))
Begin DoDot:2
+33 ;I $P(PSSDBCAR(PSSCPC5),"^",29) S $P(PSSDBCAR(PSSCPC5),"^",4)=0 ;need this to show Daily Dose error
+34 IF '$DATA(PSSDSDPL(PSSCPC5))!($PIECE(PSSDBCAR(PSSCPC5),"^",4)&('$PIECE(PSSDBCAR(PSSCPC5),"^",13)))
QUIT
+35 SET PSSCPCG1=""
IF '$PIECE(PSSDBCAR(PSSCPC5),"^",13)
IF '$PIECE(PSSDBCAR(PSSCPC5),"^",4)
SET PSSCPCG1="Max Daily Dose Check"
+36 IF '$PIECE(PSSDBCAR(PSSCPC5),"^",13)
IF PSSCPCG1=""
QUIT
+37 IF PSSCPCG1'=""
IF $PIECE(PSSDBCAR(PSSCPC5),"^",15)!($PIECE(PSSDBCAR(PSSCPC5),"^",16))!($PIECE(PSSCPC5,";",5))
KILL PSSCPCG1
QUIT
+38 IF PSSCPCG1=""
SET PSSCPCG1=$SELECT('$PIECE(PSSDBCAR(PSSCPC5),"^",15)&('$PIECE(PSSDBCAR(PSSCPC5),"^",16)):"Dosing Checks",1:"Maximum Single Dose Check")
+39 SET PSSCPBMR=$SELECT($PIECE(PSSDBCAR(PSSCPC5),"^",31):$EXTRACT($PIECE(PSSDBCAR(PSSCPC5),"^",32),1,($LENGTH($PIECE(PSSDBCAR(PSSCPC5),"^",32))-2)),1:"")_$SELECT($PIECE(PSSDBCAR(PSSCPC5),"^",16):" (Dose="_$GET(PSSDSDPL(PSSC
PC5))_")",1:"")
+40 SET PSSCPCGN=PSSCPCG1_" could not be done for Drug: "_$PIECE(PSSDBCAR(PSSCPC5),"^",2)_PSSCPBMR
+41 SET PSSCPCGN=PSSCPCGN_", please complete a manual check for appropriate Dosing."
+42 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^EXCEPTION"
+43 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=PSSCPCGN
SET PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
End DoDot:2
+44 ;
+45 KILL PSSCPCAJ
SET PSSCPCO2=""
SET (PSSCPCO3,PSSCPCAC)=0
SET PSSCPC6=""
FOR
SET PSSCPC6=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6))
if PSSCPC6=""
QUIT
Begin DoDot:2
+46 DO PEROR
SET PSSCPCNM=$PIECE(PSSCPC5,";",4)
SET PSSCPC7=""
FOR
SET PSSCPC7=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7))
if PSSCPC7=""
QUIT
Begin DoDot:3
+47 ;2.1 added the conditions
IF +PSSCPC7=2
IF $PIECE(PSSDBCAR(PSSCPC5),"^",15)!($PIECE(PSSDBCAR(PSSCPC5),"^",16))!($PIECE(PSSCPC5,";",5))
QUIT
+48 SET PSSCPC8=""
FOR
SET PSSCPC8=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8))
if PSSCPC8=""
QUIT
Begin DoDot:4
+49 IF PSSCPCO2'=""
Begin DoDot:5
+50 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^"_$SELECT(+PSSCPC7=1:"SINGLE",+PSSCPC7=2:"DAILY",1:"GENERAL")
+51 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=PSSCPCO2
End DoDot:5
+52 IF +PSSCPC7'=3
SET PSSCPCNN=$SELECT(PSSCPCO3:2,1:1)
if $GET(PSSDBADJ(PSSCPC5))'=""&($GET(PSSCPCAJ(PSSCPC5))="")
DO SADJ
Begin DoDot:5
+53 SET PSSCPCND=^TMP($JOB,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8)
IF PSSCPCAC
SET PSSCPCND=PSSCPCND_PSSCPCAJ(PSSCPC5)
+54 IF PSSCPCNN=1
SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^"_$SELECT(+PSSCPC7=1:"SINGLE",1:"DAILY")
+55 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",PSSCPCNN)=PSSCPCND
SET PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
End DoDot:5
QUIT
+56 SET PSSCPCNN=$SELECT(PSSCPCO3:1,1:0)
SET PSSCPCAA=$SELECT(PSSCPCNN:2,1:1)
+57 SET PSSCPC9=""
FOR
SET PSSCPC9=$ORDER(^TMP($JOB,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8,PSSCPC9))
if PSSCPC9=""
QUIT
Begin DoDot:5
+58 IF 'PSSCPCNN
SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^GENERAL"
+59 SET PSSCPCND=^TMP($JOB,PSSCPCGL,"OUT","DOSE",PSSCPC5,PSSCPC6,PSSCPC7,"MESSAGE",PSSCPC8,PSSCPC9)
+60 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",PSSCPCAA)=PSSCPCND
SET PSSCPCAA=PSSCPCAA+1
SET PSSCPCAR(PSSCPC5)=PSSCPCAR(PSSCPC5)+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+61 IF $PIECE(PSSDBCAR(PSSCPC5),"^",29)
DO CFREQ
End DoDot:1
+62 KILL ^TMP($JOB,PSSCPCGL)
+63 QUIT
+64 ;
+65 ;
CFREQ ;Add customized Frequency
+1 IF $PIECE(PSSDBCAR(PSSCPC5),"^",15)!($PIECE(PSSDBCAR(PSSCPC5),"^",16))!($PIECE(PSSCPC5,";",5))
QUIT
+2 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"ATYPE")="DOSE^INFORMATIONAL"
+3 SET ^TMP($JOB,PSSDBASF,"OUT","CHECK",PSSCPCNM,PSSCPC5,PSSCPCAR(PSSCPC5),"MSG",1)=$GET(^TMP($JOB,PSSDBASE,"OUT","DOSE",PSSCPC5,$PIECE(PSSDBCAR(PSSCPC5),"^",2),"FREQ","FREQUENCYCUSTOMMESSAGE",$PIECE(PSSDBCAR(PSSCPC5),"^",3)))
+4 QUIT
+5 ;
+6 ;
PEROR ;Per Orifice check
+1 NEW PSSCPCO9
+2 SET PSSCPCO9=$PIECE(PSSDBCAR(PSSCPC5),"^",9)
IF PSSCPCO9="OTIC"!(PSSCPCO9="OPHTHALMIC")!(PSSCPCO9="INTRANASAL")
Begin DoDot:1
+3 SET PSSCPCO2="Dosing Information provided is PER "_$SELECT(PSSCPCO9="OTIC":"EAR:",PSSCPCO9="OPHTHALMIC":"EYE:",1:"NOSTRIL:")
SET PSSCPCO3=1
End DoDot:1
+4 QUIT
+5 ;
+6 ;
SADJ ;Parse out Adjusted Frequency message
+1 NEW PSSSDADJ
+2 SET PSSCPCAC=1
+3 SET PSSSDADJ=$FIND(PSSDBADJ(PSSCPC5),"(")
IF 'PSSSDADJ
SET PSSCPCAJ(PSSCPC5)=" "_PSSDBADJ(PSSCPC5)
QUIT
+4 SET PSSCPCAJ(PSSCPC5)=" "_$EXTRACT(PSSDBADJ(PSSCPC5),(PSSSDADJ-1),$LENGTH(PSSDBADJ(PSSCPC5))-1)
+5 QUIT
+6 ;
+7 ;
PTH ;Local Dosage with parenthesis, extract data from before and within
+1 NEW PSSPTH1,PSSPTH2,PSSPTH3,PSSPTH4,PSSPTHL,PSSPTHA,PSSPTHC,PSSPTHF,PSSPTHD,PSSPTHS1,PSSPTHS2,PSSPTHS3,PSSPTHS4
+2 KILL PSSDSLC1
SET (PSSPTH1,PSSPTH2,PSSPTH3,PSSPTH4,PSSPTHF)=0
SET PSSPTHD=PSSDSLCL
+3 SET PSSPTHL=$LENGTH(PSSPTHD)
+4 FOR PSSPTHA=1:1:PSSPTHL
if PSSPTHF
QUIT
SET PSSPTHC=$EXTRACT(PSSPTHD,PSSPTHA)
Begin DoDot:1
+5 IF PSSPTHC'="("
IF PSSPTHC'=")"
QUIT
+6 IF PSSPTHC="("
SET PSSPTH1=PSSPTHA
SET PSSPTH3=PSSPTH3+1
if PSSPTH3>1
SET PSSPTHF=1
QUIT
+7 SET PSSPTH2=PSSPTHA
SET PSSPTH4=PSSPTH4+1
if PSSPTH4>1
SET PSSPTHF=1
QUIT
End DoDot:1
+8 ;Quit if more than 1 of either parenthesis
if PSSPTHF
QUIT
+9 ;Quit if either parenthesis is missing
if 'PSSPTH3!('PSSPTH4)
QUIT
+10 ;Quit if left paren is not before right paren
if PSSPTH1'<PSSPTH2
QUIT
+11 IF PSSPTH1>1
SET PSSPTHS1=""
Begin DoDot:1
+12 SET PSSPTHS1=$EXTRACT(PSSPTHD,1,(PSSPTH1-1))
SET PSSPTHS2=$LENGTH(PSSPTHS1)
SET PSSPTHS4=0
+13 FOR PSSPTHS3=PSSPTHS2:-1:1
IF $EXTRACT(PSSPTHS1,PSSPTHS3)'=" "
SET PSSPTHS4=PSSPTHS3
QUIT
+14 if PSSPTHS4=PSSPTHS2
QUIT
+15 IF 'PSSPTHS4
SET PSSPTHS1=""
QUIT
+16 SET PSSPTHS1=$EXTRACT(PSSPTHS1,1,PSSPTHS4)
End DoDot:1
IF PSSPTHS1'=""
SET PSSDSLC1(2)=PSSPTHS1
SET PSSDSLCT=2
+17 IF (PSSPTH1+1)'<PSSPTH2
if PSSDSLCT
Begin DoDot:1
+18 SET PSSDSLC1(1)=PSSDSLC1(2)
SET PSSDSLCT=1
KILL PSSDSLC1(2)
End DoDot:1
QUIT
+19 SET PSSDSLC1(1)=$EXTRACT(PSSPTHD,(PSSPTH1+1),(PSSPTH2-1))
IF 'PSSDSLCT
SET PSSDSLCT=1
+20 QUIT
+21 ;
+22 ;
RTEXT(PSSBAMRT,PSSBSPC) ;Set Reason Header
+1 NEW PSSBSPCS
SET PSSBSPCS=$SELECT(PSSBSPC:" ",1:"")
+2 SET PSSDWRSN=$SELECT('$PIECE(PSSDBCAR(PSSBAMRT),"^",31):PSSBSPCS_"Reason(s): ",1:PSSBSPCS_"Reason(s)"_$PIECE(PSSDBCAR(PSSBAMRT),"^",32))
+3 QUIT
+4 ;
+5 ;
ORDFREQ(PSSDADF) ; -- in 2.1 get order frequency by converting FDB frequency patterns -- called from PSSHRQ23
+1 ;PSSDADF - Frequency # or Pattern
+2 ;
+3 ;Return: Order Frequency or 0
+4 ;
+5 NEW PSSDADL,PSSDADN,PSSDADTM,PSSDADS
+6 ; -- check for missing variable, exit if not defined
+7 IF $GET(PSSDADF)']""
QUIT 0
+8 ; -- check for number
+9 IF $GET(PSSDADF)
QUIT $GET(PSSDADF)
+10 ; -- every other day
+11 IF PSSDADF="QOD"
QUIT .5
+12 ; -- set PSSDADL=Frequency Length, exit if not equal to 3 or 4
+13 SET PSSDADL=$LENGTH(PSSDADF)
IF PSSDADL'=3
IF PSSDADL'=4
QUIT 0
+14 ; -- set PSSDADS=Action associated with frequency Q=every, X=times
+15 SET PSSDADS=$EXTRACT(PSSDADF)
+16 ; -- check action associated with frequency, exit if not "Q" or "X"
+17 IF PSSDADS'="Q"
IF PSSDADS'="X"
QUIT 0
+18 ; -- set PSSDADN=Frequency Number
+19 SET PSSDADN=$EXTRACT(PSSDADF,2,$LENGTH(PSSDADF)-1)
+20 ; -- check if PSSDADN is numeric, exit if it is not
+21 IF PSSDADN'?.N
QUIT 0
+22 ; -- set PSSDADTM=period of time associated with frequency H=hour, D=day, W=week, L=month
+23 SET PSSDADTM=$EXTRACT(PSSDADF,PSSDADL)
+24 ; -- calculate order frequency every # hour(s)
+25 IF PSSDADS="Q"
IF PSSDADTM="H"
QUIT 24/PSSDADN
+26 ; -- calculate order frequency every # days(s)
+27 IF PSSDADS="Q"
IF PSSDADTM="D"
QUIT 1/PSSDADN
+28 ; -- calculate order frequency every # week(s)
+29 IF PSSDADS="Q"
IF PSSDADTM="W"
QUIT 1/(PSSDADN*7)
+30 ; -- calculate order frequency every # month(s)
+31 IF PSSDADS="Q"
IF PSSDADTM="L"
QUIT 1/(PSSDADN*30)
+32 ; -- calculate order frequency # times per day
+33 IF PSSDADS="X"
IF PSSDADTM="D"
QUIT PSSDADN
+34 ; -- calculate order frequency # times per week
+35 IF PSSDADS="X"
IF PSSDADTM="W"
QUIT PSSDADN/7
+36 ; -- calculate order frequency # times per month
+37 IF PSSDADS="X"
IF PSSDADTM="L"
QUIT PSSDADN/30
+38 QUIT 0
+39 ;
+40 ;
ROUNDNUM(X) ; -- in 2.1 if number is < or = 1, round to 4 decimals otherwise no decimals -- called from PSSHRQ23
+1 ;X - Number
+2 ;
+3 ;Return: Rounded Number or 0
+4 NEW N,ND
+5 ; -- check for missing variable, exit if not defined
+6 IF $GET(X)'>0
QUIT 0
+7 ; -- get number of decimals
+8 SET ND=$LENGTH($PIECE(+X,".",2))
+9 ; -- set number Of decimals
+10 SET N=$SELECT(+X>1:0,1:4)
+11 ; -- if number is zero, round up until number is nolonger zero
+12 IF $JUSTIFY(+X,"",N)'>0
Begin DoDot:1
+13 FOR N=1:1:ND
if $JUSTIFY(X,"",N)>0
QUIT
End DoDot:1
+14 QUIT +$JUSTIFY(X,"",N)
+15 ;
+16 ;
PRNSCHD(PSSSCHD) ;If 'PRN' appended to the schedule, return the schedule with 'PRN' remove
+1 NEW PSSXL,PSSXSCHD,PSSXSCHN
+2 IF $GET(PSSSCHD)=""
QUIT ""
+3 IF $DATA(^PS(51.1,"APPSJ",PSSSCHD))
QUIT PSSSCHD
+4 SET PSSXL=$LENGTH(PSSSCHD)
+5 ;Check name cross-index
IF $EXTRACT(PSSSCHD,(PSSXL-2),PSSXL)="PRN"
Begin DoDot:1
+6 SET PSSXSCHD=$EXTRACT(PSSSCHD,1,(PSSXL-4))
+7 IF (PSSXSCHD'="")
IF (PSSXSCHD'?." ")
if $DATA(^PS(51.1,"APPSJ",PSSXSCHD))
SET PSSSCHD=PSSXSCHD
End DoDot:1
+8 ;Check Old Schedule Name(s) cross-index PSS*1*231
IF $EXTRACT(PSSSCHD,(PSSXL-2),PSSXL)="PRN"
Begin DoDot:1
+9 SET PSSXSCHD=$EXTRACT(PSSSCHD,1,(PSSXL-4))
+10 IF (PSSXSCHD'="")
IF (PSSXSCHD'?." ")
IF $DATA(^PS(51.1,"D",PSSXSCHD))
SET PSSXSCHN=$ORDER(^PS(51.1,"D",PSSXSCHD,0))
SET PSSSCHD=$PIECE($GET(^PS(51.1,PSSXSCHN,0)),U,1)
End DoDot:1
+11 QUIT PSSSCHD
+12 ;
+13 ;
PRNMI(PSSMI) ;If 'PRN' appended to the Med instruction, return the MI with 'PRN' remove
+1 NEW PSSXL,PSSXMI
+2 IF $GET(PSSMI)=""
QUIT ""
+3 IF $DATA(^PS(51,"B",PSSMI))
QUIT PSSMI
+4 SET PSSXL=$LENGTH(PSSMI)
+5 IF $EXTRACT(PSSMI,(PSSXL-2),PSSXL)="PRN"
Begin DoDot:1
+6 SET PSSXMI=$EXTRACT(PSSMI,1,(PSSXL-4))
+7 IF (PSSXMI'="")
IF (PSSXMI'?." ")
if $DATA(^PS(51,"B",PSSXMI))
SET PSSMI=PSSXMI
End DoDot:1
+8 QUIT PSSMI
