- 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 Feb 18, 2025@23:57:27 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