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

PSSDSAPA.m

Go to the documentation of this file.
  1. PSSDSAPA ;BIR/RTR,TMK-Dose Check APIs routine (continued) ;27 Oct 2009 12:22 PM
  1. ;;1.0;PHARMACY DATA MANAGEMENT;**151,160,173,178**;9/30/97;Build 14
  1. ;
  1. IV(PSSADFOI) ;Return Additive Frequency default to CPRS, Forum DBIA 5504 ; 27 Oct 2009 12:16 PM
  1. ;PSSADFOI = File 50.7 Internal Entry Number
  1. N PSSADFRS,PSSADFIN,PSSADFLP,PSSADFXX,PSSADFHD,PSSADFLD,PSSADFNN,PSSADFER,PSSADFCT
  1. S PSSADFRS="",(PSSADFXX,PSSADFCT)=0
  1. I '$G(PSSADFOI) Q PSSADFRS
  1. F PSSADFLP=0:0 S PSSADFLP=$O(^PS(52.6,"AOI",PSSADFOI,PSSADFLP)) Q:'PSSADFLP!(PSSADFXX) D
  1. . ; Get INACTIVATION DATE and ADDITIVE FREQUENCY
  1. .S PSSADFNN=PSSADFLP_"," K PSSADFER,PSSADFLD
  1. .D GETS^DIQ(52.6,PSSADFNN,"12;18","I","PSSADFLD","PSSADFER")
  1. .I $G(PSSADFER("DIERR")) Q ; Error(s) returned
  1. .S PSSADFIN=$G(PSSADFLD(52.6,PSSADFNN,12,"I")),PSSADFHD=$G(PSSADFLD(52.6,PSSADFNN,18,"I"))
  1. . ; Only consider if not inactive as of today
  1. .I PSSADFIN,PSSADFIN'>DT Q
  1. . ; If no frequency returned, set error flag, look no further
  1. .I PSSADFHD="" S PSSADFXX=1 Q
  1. . ; Save first non-null value found
  1. .I 'PSSADFCT S PSSADFRS=PSSADFHD,PSSADFCT=1 Q
  1. . ; Second or later match found and isn't the same value
  1. . ; as first match value, set error flag, quit
  1. .I PSSADFHD'=PSSADFRS S PSSADFXX=1
  1. ; If error found, return null
  1. I PSSADFXX S PSSADFRS=""
  1. Q PSSADFRS
  1. ;
  1. ;
  1. RESET ;Reset array to set flag to show General Dosing Guideline for last unique combination of Drug and Route
  1. N PSSDBCD1,PSSDBCD2,PSSDBCD3,PSSDBCD4
  1. S PSSDBCD1="" F S PSSDBCD1=$O(PSSDBCDA(PSSDBCD1)) Q:PSSDBCD1="" D
  1. .S PSSDBCD2="" F S PSSDBCD2=$O(PSSDBCDA(PSSDBCD1,PSSDBCD2)) Q:PSSDBCD2="" D
  1. ..S PSSDBCD3=PSSDBCDA(PSSDBCD1,PSSDBCD2)
  1. ..I PSSDBCD3'="" S PSSDBCDP(PSSDBRLS,PSSDBCD3)=""
  1. Q
  1. ;
  1. ;
  1. SGEN ;General Dosing Guidelines for last dosing sequence of a complex order when there is an error
  1. N PSSDBCD5,PSSDBCD6,PSSDBCD7,PSSDBCD8
  1. S PSSDBCD6=1
  1. S PSSDBCD5="" F S PSSDBCD5=$O(PSSDBCDP(PSSDWE5,PSSDBCD5)) Q:PSSDBCD5="" D SGENA
  1. Q
  1. ;
  1. ;
  1. SGENA ;
  1. S PSSDBCD7=$P($G(PSSDBCAR(PSSDBCD5)),"^",2),PSSDBCD8=$P($G(PSSDBCAR(PSSDBCD5)),"^",3)
  1. I PSSDBCD7=""!(PSSDBCD8="") Q
  1. I $G(^TMP($J,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8))'="" D S PSSDBCD6=PSSDBCD6+1 Q
  1. .I PSSDBASA S ^TMP($J,PSSDBASF,"OUT","DOSE",PSSDWE5,PSSDBCD7,"3_GENERAL","MESSAGE",PSSDBCD8,PSSDBCD6)=^TMP($J,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8)
  1. .I PSSDBASB S ^TMP($J,PSSDBASG,"OUT",PSSDWE5,"MESSAGE","3_GENERAL",PSSDBCD8,PSSDBCD6)=^TMP($J,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8)
  1. Q
  1. ;
  1. ;
  1. REM ;Remove certian output globals to comply with 2.1 requirements
  1. N PSSRMV1,PSSRMV2,PSSRMV3,PSSRMV4,PSSRMV5,PSSRMV6,PSSRMV7,PSSRMV8,PSSRMV9,PSSRMVX,PSSPERR
  1. ;
  1. I PSSDBASB D
  1. .S PSSRMV1="" F S PSSRMV1=$O(^TMP($J,PSSDBASG,"OUT",PSSRMV1)) Q:PSSRMV1="" D
  1. ..S PSSRMV2="" F S PSSRMV2=$O(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2)) Q:PSSRMV2="" D
  1. ...I $P(PSSDBCAR(PSSRMV2),"^",14) K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2) Q
  1. ...S PSSRMV7="" F S PSSRMV7=$O(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7)) Q:PSSRMV7="" D
  1. ....I $G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"WARN"))="Warning",'$P(PSSRMV2,";",5) K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"WARN") S $P(PSSDBCAR(PSSRMV2),"^",13)="" Q
  1. ....Q ;2.0 Change to now show specific errors
  1. ....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"MSG")
  1. ....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"TEXT")
  1. ...I $P(PSSDBCAR(PSSRMV2),"^",15)!($P(PSSDBCAR(PSSRMV2),"^",16))!($P(PSSRMV2,";",5)) K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE") ;2.1 added piece 15 and 16 check
  1. ...; -- 2.1 added - if Max Single Dose and Max Daily Dose Order Check messages are the same only show one
  1. ...N PSSDWIEN
  1. ...S PSSDWIEN=+$P(PSSDBCAR(PSSRMV2),"^",3)
  1. ...I $G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE",PSSDWIEN))]"",($G(^(PSSDWIEN)))=$G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE",PSSDWIEN)) D
  1. ....S ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE_RANGE",PSSDWIEN)=$G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE",PSSDWIEN))
  1. ....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE")
  1. ....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE")
  1. ...I $O(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE",""))'="" D
  1. ....S PSSPERR=$P(PSSDBCAR(PSSRMV2),"^",9) I PSSPERR="OTIC"!(PSSPERR="OPHTHALMIC")!(PSSPERR="INTRANASAL") D
  1. .....S ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE",".1_INTRO")="Dosing Information provided is PER "_$S(PSSPERR="OTIC":"EAR:",PSSPERR="OPHTHALMIC":"EYE:",1:"NOSTRIL:")
  1. ;
  1. ; -- in 2.1 if max daily dose frequency out of range flag=1 for custom frequency message
  1. I PSSDBASB D
  1. . N PSSDADO
  1. . S PSSDADO="" F S PSSDADO=$O(PSSDBCAR(PSSDADO)) Q:PSSDADO="" I $P(PSSDBCAR(PSSDADO),"^",29) D CHKCFREQ^PSSDSUTA(PSSDADO,PSSDBASE,PSSDBASG,.PSSDBCAR)
  1. ;
  1. I PSSDBASA D UPCPRS^PSSDSUTL
  1. ;
  1. S PSSRMV8="" F S PSSRMV8=$O(PSSDBCAR(PSSRMV8)) Q:PSSRMV8="" I $P(PSSDBCAR(PSSRMV8),"^",13),$D(PSSDSDPL(PSSRMV8)),'$P(PSSDBCAR(PSSRMV8),"^",14) D
  1. .S PSSRMVX=$S('$P(PSSDBCAR(PSSRMV8),"^",15)&('$P(PSSDBCAR(PSSRMV8),"^",16)):"Dosing Checks",1:"Maximum Single Dose Check")
  1. .I PSSDBASB,$P(PSSDBCAR(PSSRMV8),"^",17) D
  1. ..S ^TMP($J,PSSDBASG,"OUT",$P(PSSRMV8,";",4),PSSRMV8,"EXCEPTIONS",1)=PSSRMVX_" could not be performed for Drug: "_$P(PSSDBCAR(PSSRMV8),"^",2)_", please complete a manual check for appropriate Dosing."
  1. Q
  1. ;
  1. ;
  1. SQX(PSSQBSS) ;returns Dosage check exclusion information based on Schedule
  1. N PSSQBA1,PSSQBA2,PSSQBA3,PSSQBA4,PSSQBA5,PSSQBA6,PSSQBARS,PSSQBFLG,PSSQBSTM,PSSQBSTP
  1. S PSSQBARS="",PSSQBFLG=0
  1. I $G(PSSQBSS)="" Q PSSQBARS
  1. S PSSQBSTM=PSSQBSS D SQXLP I PSSQBFLG Q PSSQBARS
  1. S PSSQBA3=$L(PSSQBSS) I PSSQBA3>4 S PSSQBA4=$E(PSSQBSS,(PSSQBA3-3),PSSQBA3) S PSSQBA4=$$UP^XLFSTR(PSSQBA4) I PSSQBA4=" PRN" S PSSQBSTM=$E(PSSQBSS,1,(PSSQBA3-4)) D SQXLP I PSSQBFLG Q PSSQBARS
  1. I PSSQBSS'["@" Q PSSQBARS
  1. S PSSQBA5=$L(PSSQBSS),PSSQBA6=$F(PSSQBSS,"@") I PSSQBA6>PSSQBA5 Q PSSQBARS
  1. S (PSSQBSTM,PSSQBSTP)=$E(PSSQBSS,PSSQBA6,PSSQBA5) D SQXLP I PSSQBFLG Q PSSQBARS
  1. S PSSQBA3=$L(PSSQBSTP) I PSSQBA3>4 S PSSQBA4=$E(PSSQBSTP,(PSSQBA3-3),PSSQBA3) S PSSQBA4=$$UP^XLFSTR(PSSQBA4) I PSSQBA4=" PRN" S PSSQBSTM=$E(PSSQBSTP,1,(PSSQBA3-4)) D SQXLP
  1. Q PSSQBARS
  1. ;
  1. ;
  1. SQXLP ;
  1. F PSSQBA1=0:0 S PSSQBA1=$O(^PS(51.1,"APPSJ",PSSQBSTM,PSSQBA1)) Q:'PSSQBA1!(PSSQBFLG) D
  1. .S PSSQBA2=$G(^PS(51.1,PSSQBA1,0)) I PSSQBA2="" Q
  1. .S PSSQBARS=$P(PSSQBA2,"^",9)_"^"_$P(PSSQBA2,"^",10),PSSQBFLG=1
  1. Q
  1. ;
  1. ;
  1. SXCL ;Set exclusion fields in PSSDBCAR array
  1. N PSSQBGR,PSSQBGT
  1. S PSSQBGR=$G(PSSDBFRC(PSSDBKLP,"SCHEDULE")) I PSSQBGR="" Q
  1. S PSSQBGT=$$SQX(PSSQBGR)
  1. S:$P(PSSQBGT,"^") $P(PSSDBCAR(PSSDBKLP),"^",14)=1
  1. S:$P(PSSQBGT,"^",2) $P(PSSDBCAR(PSSDBKLP),"^",15)=1
  1. Q
  1. ;
  1. ;
  1. NOTS ;Set flag for not screened
  1. N PSSNSCRE,PSSNSCRU
  1. S PSSNSCRE=$G(^TMP($J,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSDWL1,"SEV"))
  1. S PSSNSCRU=$$UP^XLFSTR(PSSNSCRE)
  1. I PSSNSCRU["NOTSCREENED" S $P(PSSDBCAR(PSSDWLP),"^",13)=1
  1. Q
  1. ;
  1. ;
  1. SOL(PSSLGTOI) ;
  1. ;Return 1 for premix solution
  1. ;Return 0 for solution not marked for premix
  1. ;The second piece is 0 if there is no active solution found
  1. ;If no active solution found and at least 1 premix then consider it's a premix
  1. NEW PSSLGT1,PSSLGT2,PSSLGT3,PSSSOL,PSSPRE
  1. I '+$G(PSSLGTOI) Q 0_U_0
  1. S PSSINADT=$P($G(^PS(50.7,PSSLGTOI,0)),U,4)
  1. I PSSINADT,(PSSINADT'>DT) Q 0_U_0
  1. S PSSLGT2=0,PSSSOL=0,PSSPRE=0
  1. F PSSLGT1=0:0 S PSSLGT1=$O(^PS(52.7,"AOI",PSSLGTOI,PSSLGT1)) Q:'PSSLGT1!(PSSLGT2) D
  1. .I $P($G(^PS(52.7,PSSLGT1,0)),"^",14)=1 S PSSPRE=1
  1. .S PSSLGT3=$P($G(^PS(52.7,PSSLGT1,"I")),"^") I PSSLGT3,(PSSLGT3'>DT) Q
  1. .S:PSSPRE PSSLGT2=1
  1. .S PSSSOL=1
  1. I 'PSSSOL,PSSPRE Q PSSPRE_U_PSSSOL
  1. Q PSSLGT2_U_PSSSOL
  1. ;
  1. ;
  1. IPM(PSSLGTOI) ;
  1. ;Return 1 if it's a UD, additive, or a premix solution
  1. NEW PSSINADT,PSSIEN,PSSUD,PSSAD,PSSSOL
  1. I '+$G(PSSLGTOI) Q 0
  1. S (PSSUD,PSSAD,PSSSOL)=0
  1. S PSSINADT=$P($G(^PS(50.7,PSSLGTOI,0)),U,4)
  1. I PSSINADT,(PSSINADT'>DT) Q 0
  1. F PSSIEN=0:0 S PSSIEN=$O(^PSDRUG("ASP",PSSLGTOI,PSSIEN)) Q:'PSSIEN!PSSUD D
  1. . S PSSINADT=$P($G(^PSDRUG(PSSIEN,"I")),U)
  1. . I PSSINADT,(PSSINADT'>DT) Q
  1. . I $P($G(^PSDRUG(PSSIEN,2)),U,3)["U" S PSSUD=1 Q
  1. I PSSUD Q 1
  1. F PSSIEN=0:0 S PSSIEN=$O(^PS(52.6,"AOI",PSSLGTOI,PSSIEN)) Q:'PSSIEN!PSSAD D
  1. . S PSSAD=1 Q
  1. I PSSAD Q 1
  1. S PSSSOL=$$SOL(PSSLGTOI)
  1. ;If the is an active solution, $P(PSSSOL,U) is 1 if it's marked for premix
  1. Q $P(PSSSOL,U)
  1. ;
  1. ;
  1. ONT ;Look for one to one relationship from Dispense Drug to Orderable Item for application
  1. N PSSOTOD,PSSOTOI,PSSOTOL,PSSOTOF,PSSOTOA,PSSOTON,PSSOTOB1,PSSOTOB2,PSSOTOB3,PSSOTOB4
  1. S PSSOTOF=0
  1. S PSSOTOI=$P($G(^PSDRUG(+PSSDBIFG,2)),"^") I 'PSSOTOI Q
  1. F PSSOTOL=0:0 S PSSOTOL=$O(^PSDRUG("ASP",PSSOTOI,PSSOTOL)) Q:'PSSOTOL!(PSSOTOF) D:PSSOTOL'=+PSSDBIFG
  1. .I $$EXMT^PSSDSAPI(PSSOTOL) Q
  1. .S PSSOTOD=$P($G(^PSDRUG(PSSOTOL,"I")),"^") I PSSOTOD,PSSOTOD'>DT Q
  1. .S PSSOTOA=$P($G(^PSDRUG(PSSOTOL,2)),"^",3),PSSOTOA=$TR(PSSOTOA,"U","I")
  1. .I PSSOTOA'[$G(PSSDBFDB("PACKAGE")) Q
  1. .S PSSOTOB2=$G(^PSDRUG(PSSOTOL,"ND")),PSSOTOB1=$P(PSSOTOB2,"^"),PSSOTOB3=$P(PSSOTOB2,"^",3) I 'PSSOTOB1!('PSSOTOB3) Q
  1. .S PSSOTOB4=$$PROD0^PSNAPIS(PSSOTOB1,PSSOTOB3) I '$P(PSSOTOB4,"^",7) Q
  1. .S PSSOTOF=1
  1. Q:PSSOTOF
  1. S PSSDBIFL=0,PSSOTON=$P($G(^PSDRUG(+PSSDBIFG,0)),"^")
  1. S PSSDBFDB(PSSDBLP,"DRUG_NM")=$S(PSSOTON'="":PSSOTON,1:"UNKNOWN DRUG NAME")
  1. S PSSDBFDB(PSSDBLP,"DRUG_IEN")=+PSSDBIFG
  1. Q
  1. ;
  1. ;
  1. TLS(PSSTLS1,PSSTLS2) ;
  1. N PSSTLS5,PSSTLS6,PSSTLS7
  1. S PSSTLS5=$$DFSU^PSNAPIS(PSSTLS1,PSSTLS2)
  1. S PSSTLS6=$P(PSSTLS5,"^",4),PSSTLS7=$P(PSSTLS5,"^",5)
  1. I 'PSSTLS7!(PSSTLS6="") Q 1
  1. I '$D(^PS(50.607,PSSTLS7,0)) Q 1
  1. I PSSTLS6'?.N&(PSSTLS6'?.N1".".N) Q 1
  1. Q 0
  1. ;
  1. ;
  1. INRATE ;Infusion Rate error, default data already set in Inpatient
  1. ;N PSSDBEC1
  1. I 'PSSDBEB3 Q
  1. I $P(PSSDBEB2,"^",5)=""!($P(PSSDBEB2,"^",6)="") D EXCPS^PSSDSAPD(1)
  1. ;S PSSDBEC1=$P(PSSDBEB2,"^",11) S PSSDBEC1=$$UP^XLFSTR(PSSDBEC1) I $E(PSSDBEC1,1,4)'="CONT" Q
  1. S $P(PSSDBCAR(PSSDBEB1),"^",21)=1
  1. D EXCPS^PSSDSAPD(3) D INFERRS^PSSDSAPK
  1. I $D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) D EXCPS^PSSDSAPD(2)
  1. I $P(PSSDBCAR(PSSDBEB1),"^",5) S $P(PSSDBCAR(PSSDBEB1),"^",6)=1 S $P(PSSDBCAR(PSSDBEB1),"^",10)=1 Q ;Maintenance Dose
  1. ;Single Dose, code should never be invoked, because we don't send Continuous infusions
  1. S $P(PSSDBCAR(PSSDBEB1),"^")="S"
  1. S $P(PSSDBCAR(PSSDBEB1),"^",7)=1
  1. Q
  1. ;
  1. ;
  1. INFRQ ;Frequency error
  1. I 'PSSDBEB3 Q
  1. I $P(PSSDBEB2,"^",11)="" Q
  1. ;I '$P(PSSDBCAR(PSSDBEB1),"^",5) Q
  1. D EXCPS^PSSDSAPD(2)
  1. S $P(PSSDBCAR(PSSDBEB1),"^")="S"
  1. I $P(PSSDBCAR(PSSDBEB1),"^",5) S $P(PSSDBCAR(PSSDBEB1),"^",8)=1 S $P(PSSDBCAR(PSSDBEB1),"^",10)=1
  1. ;Inpatient may already be setting next 3, because this applies to Outpatient and IV
  1. S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1,$P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
  1. ;S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
  1. S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",10)=$P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",7)
  1. ; -- in 2.1 set Dummy Data flag
  1. S $P(PSSDBCAR(PSSDBEB1),"^",33)=1
  1. Q
  1. ;
  1. ;
  1. DUNIT() ;Find unit
  1. ;Piece 3 of PSSDBCAR must be a File 50 IEN
  1. N PSSDBEG1,PSSDBEG2,PSSDBEG3,PSSDBEG4,PSSDBEG5,PSSDBEG6,PSSDBEG7,X,Y
  1. S PSSDBEG4=""
  1. S PSSDBEG1=$P(PSSDBCAR(PSSDBEB1),"^",3)
  1. I PSSDBEG1 D I PSSDBEG4'="" Q PSSDBEG4
  1. .S PSSDBEG2=$P($G(^PSDRUG(PSSDBEG1,"ND")),"^"),PSSDBEG3=$P($G(^PSDRUG(PSSDBEG1,"ND")),"^",3)
  1. .I 'PSSDBEG2!('PSSDBEG3) Q
  1. .S PSSDBEG5=$$DFSU^PSNAPIS(PSSDBEG2,PSSDBEG3)
  1. .S PSSDBEG6=$P(PSSDBEG5,"^",6)
  1. .I PSSDBEG6'="" S PSSDBEG7=$$UNIT^PSSDSAPI(PSSDBEG6) I PSSDBEG7'="" S PSSDBEG4=PSSDBEG7
  1. I PSSDBEG1 F PSSDBEG2=0:0 S PSSDBEG2=$O(^PSDRUG(PSSDBEG1,"DOS2",PSSDBEG2)) Q:'PSSDBEG2!(PSSDBEG4'="") D
  1. .S PSSDBEG3=$P($G(^PSDRUG(PSSDBEG1,"DOS2",PSSDBEG2,0)),"^",5)
  1. .I PSSDBEG3,$P($G(^PS(51.24,PSSDBEG3,0)),"^",2)'="" S PSSDBEG4=$P(^PS(51.24,PSSDBEG3,0),"^",2)
  1. I PSSDBEG4'="" Q PSSDBEG4
  1. I PSSDBEG1 S PSSDBEG2=$P($G(^PSDRUG(PSSDBEG1,2)),"^") I PSSDBEG2 D
  1. .S PSSDBEG3=$P($G(^PS(50.7,PSSDBEG2,0)),"^",2) I PSSDBEG3 D
  1. ..F PSSDBEG5=0:0 S PSSDBEG5=$O(^PS(50.606,PSSDBEG3,"NOUN",PSSDBEG5)) Q:'PSSDBEG5!(PSSDBEG4'="") D
  1. ...S PSSDBEG6=$P($G(^PS(50.606,PSSDBEG3,"NOUN",PSSDBEG5,0)),"^")
  1. ...I PSSDBEG6'="" S PSSDBEG7=$$UNIT^PSSDSAPI(PSSDBEG6) I PSSDBEG7'="" S PSSDBEG4=PSSDBEG7
  1. I PSSDBEG4'="" Q PSSDBEG4
  1. Q "EACH"