- PSSUTIL1 ;BIR/RTR-Utility routine ;08/21/00
- ;;1.0;PHARMACY DATA MANAGEMENT;**38,66,69**;9/30/97
- ;Reference to ^PS(50.607 supported by DBIA #2221
- ;Reference to ^PSNAPIS supported by DBIA 2531
- ;
- EN(PSSDRIEN) ;
- N PSSMASH,PSSMNDFS,PSSMSSTR,PSSMUNIT,PSSUNZ,PSSMA,PSSMB,PSSMA1,PSSMB1,PSSUNX,PSSMASH2,PSSMASH3,PSSNAT1,PSSNAT3,PSSNODEU
- I '$G(PSSDRIEN) Q "|^^^^^99PSU"
- S PSSMSSTR=$P($G(^PSDRUG(PSSDRIEN,"DOS")),"^"),PSSMUNIT=$P($G(^("DOS")),"^",2)
- S PSSNAT1=$P($G(^PSDRUG(PSSDRIEN,"ND")),"^"),PSSNAT3=$P($G(^("ND")),"^",3) I PSSNAT1,PSSNAT3 S PSSNODEU=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT3) S PSSMNDFS=$P(PSSNODEU,"^",4) S:'$G(PSSMUNIT) PSSMUNIT=$P(PSSNODEU,"^",5)
- S PSSUNZ=$P($G(^PS(50.607,+$G(PSSMUNIT),0)),"^")
- I PSSUNZ'["/" Q $S($G(PSSMSSTR)'="":$G(PSSMSSTR),$G(PSSMNDFS)'="":$G(PSSMNDFS),1:"")_"|"_"^^^"_$S($G(PSSMUNIT):$G(PSSMUNIT),1:"")_"^"_$G(PSSUNZ)_"^"_"99PSU"
- S PSSMASH=0
- I $G(PSSMSSTR),$G(PSSMNDFS),+$G(PSSMSSTR)'=+$G(PSSMNDFS) S PSSMASH=1
- I 'PSSMASH Q PSSMSSTR_"|"_"^^^"_$S($G(PSSMUNIT):$G(PSSMUNIT),1:"")_"^"_$G(PSSUNZ)_"^"_"99PSU"
- S PSSMA=$P(PSSUNZ,"/"),PSSMB=$P(PSSUNZ,"/",2),PSSMA1=+$G(PSSMA),PSSMB1=+$G(PSSMB)
- S PSSMASH2=PSSMSSTR/PSSMNDFS,PSSMASH3=PSSMASH2*($S($G(PSSMB1):$G(PSSMB1),1:1))
- S PSSUNX=$G(PSSMA)_"/"_$G(PSSMASH3)_$S('$G(PSSMB1):$G(PSSMB),1:$P(PSSMB,PSSMB1,2))
- Q $S($G(PSSMSSTR)'="":$G(PSSMSSTR),$G(PSSMNDFS)'="":$G(PSSMNDFS),1:"")_"|"_"^^^^"_$G(PSSUNX)_"^"_"99PSU"
- ;
- Q
- ;
- DRG(PSSDD,PSSOI,PSSPK) ;
- ; PSSDD - Array of Drugs
- ; PSSOI - Orderable Item (Pharmacy)
- ; PSSPK - Application Package ("O"-Outpatient;"I"-IV;"X"-Non-VA Med)
- ;Return active dispense drugs for package based on Orderable Item
- N PSSL,PSSAP,PSSIN,PSSND
- Q:'$G(PSSOI)
- I $G(PSSPK)'="O",$G(PSSPK)'="I",$G(PSSPK)'="X" Q
- F PSSL=0:0 S PSSL=$O(^PSDRUG("ASP",PSSOI,PSSL)) Q:'PSSL D
- . S PSSIN=$P($G(^PSDRUG(PSSL,"I")),"^"),PSSAP=$P($G(^(2)),"^",3)
- . I PSSIN,PSSIN<DT Q
- . S PSSND=$P($G(^PSDRUG(PSSL,"ND")),"^")
- . I PSSPK="O"!(PSSPK="X") D Q
- . . S:PSSAP[PSSPK PSSDD(PSSL_";"_PSSND)=$P($G(^PSDRUG(PSSL,0)),"^")
- . I PSSAP["I"!(PSSAP["U") D
- . . S PSSDD(PSSL_";"_PSSND)=$P($G(^PSDRUG(PSSL,0)),"^")
- Q
- ;
- ITEM(PSSIT,PSSDR) ;Return Orderable Item to CPRS
- N PSSNEW
- I '$G(PSSIT)!('$G(PSSDR)) Q -1
- I '$D(^PS(50.7,+$G(PSSIT),0))!('$D(^PSDRUG(+$G(PSSDR),0))) Q -1
- S PSSNEW=+$P($G(^PSDRUG(+$G(PSSDR),2)),"^")
- I PSSNEW,PSSNEW=$G(PSSIT) Q 0
- I PSSNEW,PSSNEW'=$G(PSSIT) Q 1_"^"_PSSNEW
- Q -1
- ;
- Q
- ;
- EN1(PSSOA,PSSOAP) ;
- ;Return Orderable Item Forumary Alternatives to CPRS
- ;PSSOA = Pharmacy Orderable Item number
- ;PSSOAP = "I" For Inpatient, "O" For Outpatient
- Q:'$G(PSSOA)
- I $G(PSSOAP)'="O",$G(PSSOAP)'="I" Q
- N PSSOAL,PSSOALD,PSSOAN,PSSOAIT,PSSOADT,PSSOAZ
- S PSSOAL="" F S PSSOAL=$O(^PSDRUG("ASP",PSSOA,PSSOAL)) Q:PSSOAL="" D
- .S PSSOALD="" F S PSSOALD=$O(^PSDRUG(PSSOAL,65,PSSOALD)) Q:PSSOALD="" D
- ..S PSSOAN=$P($G(^PSDRUG(PSSOAL,65,PSSOALD,0)),"^") I PSSOAN S PSSOAIT=$P($G(^PSDRUG(PSSOAN,2)),"^") D:PSSOAIT
- ...Q:PSSOAIT=PSSOA
- ...Q:$D(PSSOA(PSSOAIT))
- ...Q:'$D(^PS(50.7,PSSOAIT,0))!($P($G(^PS(50.7,PSSOAIT,0)),"^",12))
- ...Q:$P($G(^PS(50.7,PSSOAIT,0)),"^",4)&(+$P($G(^(0)),"^",4)'>DT)
- ...S PSSOAZ="" F S PSSOAZ=$O(^PSDRUG("ASP",PSSOAIT,PSSOAZ)) Q:PSSOAZ=""!($D(PSSOA(PSSOAIT))) D
- ....Q:$P($G(^PSDRUG(PSSOAZ,"I")),"^")&(+$P($G(^("I")),"^")'>DT)
- ....Q:$P($G(^PSDRUG(PSSOAZ,0)),"^",9)
- ....I $G(PSSOAP)="O" S:$P($G(^PSDRUG(PSSOAZ,2)),"^",3)["O" PSSOA(PSSOAIT)="" Q
- ....I $P($G(^PSDRUG(PSSOAZ,2)),"^",3)["I"!($P($G(^(2)),"^",3)["U") S PSSOA(PSSOAIT)=""
- Q
- SCH(SCH) ;Expand schedule for Outpatient order in CPRS
- N SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST,SCHEX
- S SCHEX=$G(SCH) S SQFLAG=0
- I $G(SCH)="" G SCHQT
- ;I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
- F SCLOOP=0:0 S SCLOOP=$O(^PS(51.1,"B",SCH,SCLOOP)) Q:'SCLOOP!(SQFLAG) I $P($G(^PS(51.1,SCLOOP,0)),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SQFLAG=1
- I SQFLAG G SCHQT
- I $P($G(^PS(51,"A",SCH)),"^")'="" S SCHEX=$P(^(SCH),"^") G SCHQT
- S SCLOOP=0 F SCLP=1:1:$L(SCH) S SCLPS=$E(SCH,SCLP) I SCLPS=" " S SCLOOP=SCLOOP+1
- I SCLOOP=0 S SCHEX=SCH G SCHQT
- S SCLOOP=SCLOOP+1
- K SCLHOLD F SCIN=1:1:SCLOOP S (SODL,SCLHOLD(SCIN))=$P(SCH," ",SCIN) D
- .Q:$G(SODL)=""
- .S SQFLAG=0 F SST=0:0 S SST=$O(^PS(51.1,"B",SODL,SST)) Q:'SST!($G(SQFLAG)) I $P($G(^PS(51.1,SST,0)),"^",8)'="" S SCLHOLD(SCIN)=$P($G(^(0)),"^",8),SQFLAG=1
- .Q:$G(SQFLAG)
- .I $P($G(^PS(51,"A",SODL)),"^")'="" S SCLHOLD(SCIN)=$P(^(SODL),"^")
- S SCHEX="",SQFLAG=0 F SST=1:1:SCLOOP S SCHEX=SCHEX_$S($G(SQFLAG):" ",1:"")_$G(SCLHOLD(SST)),SQFLAG=1
- SCHQT ;
- S SCH=SCHEX
- Q
- ;
- IVDEA(PSSIVOI,PSSIVOIP) ;DEA Special Handling to CPRS for IV Fluids dialogue
- ;parameter 1 is Orderable Item
- ;parameter 2 is "A" for Additive, "S" for Solution
- ;Return variables: 1 - DEA contains a 1 or a 2
- ;2 - DEA contains a 3, 4, or 5
- ;0 - first 2 conditions not met, but active additive/solutions exist
- ;null - no active additive/solution for the Orderable Item
- N PSSIVDO,PSSIVDD,PSSIVL,PSSIVLP,PSSIVDEA,PSSIVLPX
- S (PSSIVDO,PSSIVDD)=0
- I $G(PSSIVOIP)'="S" S PSSIVOIP="A"
- I '$G(PSSIVOI) G IVQ
- S PSSIVL="" F S PSSIVL=$O(^PSDRUG("ASP",PSSIVOI,PSSIVL)) Q:PSSIVL=""!(PSSIVDO=1) D
- .I $P($G(^PSDRUG(PSSIVL,"I")),"^"),$P($G(^("I")),"^")<DT Q
- .I $P($G(^PSDRUG(PSSIVL,2)),"^",3)'["I",$P($G(^(2)),"^",3)'["U" Q
- .I PSSIVOIP="A" D Q
- ..S PSSIVLP="",PSSIVLPX=0 F S PSSIVLP=$O(^PSDRUG("A526",PSSIVL,PSSIVLP)) Q:PSSIVLP=""!(PSSIVDO=1)!(PSSIVLPX) D
- ...I $D(^PS(52.6,PSSIVLP,0)) I '$P($G(^("I")),"^")!($P($G(^("I")),"^")>DT) S (PSSIVDD,PSSIVLPX)=1 D IVX
- .S PSSIVLP="",PSSIVLPX=0 F S PSSIVLP=$O(^PSDRUG("A527",PSSIVL,PSSIVLP)) Q:PSSIVLP=""!(PSSIVDO=1)!(PSSIVLPX) D
- ..I $D(^PS(52.7,PSSIVLP,0)) I '$P($G(^("I")),"^")!($P($G(^("I")),"^")>DT) S (PSSIVDD,PSSIVLPX)=1 D IVX
- IVQ ;
- I PSSIVDO=0,'PSSIVDD S PSSIVDO=""
- Q PSSIVDO
- ;
- IVX ;
- S PSSIVDEA=$P($G(^PSDRUG(PSSIVL,0)),"^",3)
- I PSSIVDEA[1!(PSSIVDEA[2) S PSSIVDO=1 Q
- I PSSIVDEA[3!(PSSIVDEA[4)!(PSSIVDEA[5) S PSSIVDO=2
- Q
- PSSUTIL1 ;BIR/RTR-Utility routine ;08/21/00
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**38,66,69**;9/30/97
- +2 ;Reference to ^PS(50.607 supported by DBIA #2221
- +3 ;Reference to ^PSNAPIS supported by DBIA 2531
- +4 ;
- EN(PSSDRIEN) ;
- +1 NEW PSSMASH,PSSMNDFS,PSSMSSTR,PSSMUNIT,PSSUNZ,PSSMA,PSSMB,PSSMA1,PSSMB1,PSSUNX,PSSMASH2,PSSMASH3,PSSNAT1,PSSNAT3,PSSNODEU
- +2 IF '$GET(PSSDRIEN)
- QUIT "|^^^^^99PSU"
- +3 SET PSSMSSTR=$PIECE($GET(^PSDRUG(PSSDRIEN,"DOS")),"^")
- SET PSSMUNIT=$PIECE($GET(^("DOS")),"^",2)
- +4 SET PSSNAT1=$PIECE($GET(^PSDRUG(PSSDRIEN,"ND")),"^")
- SET PSSNAT3=$PIECE($GET(^("ND")),"^",3)
- IF PSSNAT1
- IF PSSNAT3
- SET PSSNODEU=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT3)
- SET PSSMNDFS=$PIECE(PSSNODEU,"^",4)
- IF '$GET(PSSMUNIT)
- SET PSSMUNIT=$PIECE(PSSNODEU,"^",5)
- +5 SET PSSUNZ=$PIECE($GET(^PS(50.607,+$GET(PSSMUNIT),0)),"^")
- +6 IF PSSUNZ'["/"
- QUIT $SELECT($GET(PSSMSSTR)'="":$GET(PSSMSSTR),$GET(PSSMNDFS)'="":$GET(PSSMNDFS),1:"")_"|"_"^^^"_$SELECT($GET(PSSMUNIT):$GET(PSSMUNIT),1:"")_"^"_$GET(PSSUNZ)_"^"_"99PSU"
- +7 SET PSSMASH=0
- +8 IF $GET(PSSMSSTR)
- IF $GET(PSSMNDFS)
- IF +$GET(PSSMSSTR)'=+$GET(PSSMNDFS)
- SET PSSMASH=1
- +9 IF 'PSSMASH
- QUIT PSSMSSTR_"|"_"^^^"_$SELECT($GET(PSSMUNIT):$GET(PSSMUNIT),1:"")_"^"_$GET(PSSUNZ)_"^"_"99PSU"
- +10 SET PSSMA=$PIECE(PSSUNZ,"/")
- SET PSSMB=$PIECE(PSSUNZ,"/",2)
- SET PSSMA1=+$GET(PSSMA)
- SET PSSMB1=+$GET(PSSMB)
- +11 SET PSSMASH2=PSSMSSTR/PSSMNDFS
- SET PSSMASH3=PSSMASH2*($SELECT($GET(PSSMB1):$GET(PSSMB1),1:1))
- +12 SET PSSUNX=$GET(PSSMA)_"/"_$GET(PSSMASH3)_$SELECT('$GET(PSSMB1):$GET(PSSMB),1:$PIECE(PSSMB,PSSMB1,2))
- +13 QUIT $SELECT($GET(PSSMSSTR)'="":$GET(PSSMSSTR),$GET(PSSMNDFS)'="":$GET(PSSMNDFS),1:"")_"|"_"^^^^"_$GET(PSSUNX)_"^"_"99PSU"
- +14 ;
- +15 QUIT
- +16 ;
- DRG(PSSDD,PSSOI,PSSPK) ;
- +1 ; PSSDD - Array of Drugs
- +2 ; PSSOI - Orderable Item (Pharmacy)
- +3 ; PSSPK - Application Package ("O"-Outpatient;"I"-IV;"X"-Non-VA Med)
- +4 ;Return active dispense drugs for package based on Orderable Item
- +5 NEW PSSL,PSSAP,PSSIN,PSSND
- +6 IF '$GET(PSSOI)
- QUIT
- +7 IF $GET(PSSPK)'="O"
- IF $GET(PSSPK)'="I"
- IF $GET(PSSPK)'="X"
- QUIT
- +8 FOR PSSL=0:0
- SET PSSL=$ORDER(^PSDRUG("ASP",PSSOI,PSSL))
- IF 'PSSL
- QUIT
- Begin DoDot:1
- +9 SET PSSIN=$PIECE($GET(^PSDRUG(PSSL,"I")),"^")
- SET PSSAP=$PIECE($GET(^(2)),"^",3)
- +10 IF PSSIN
- IF PSSIN<DT
- QUIT
- +11 SET PSSND=$PIECE($GET(^PSDRUG(PSSL,"ND")),"^")
- +12 IF PSSPK="O"!(PSSPK="X")
- Begin DoDot:2
- +13 IF PSSAP[PSSPK
- SET PSSDD(PSSL_";"_PSSND)=$PIECE($GET(^PSDRUG(PSSL,0)),"^")
- End DoDot:2
- QUIT
- +14 IF PSSAP["I"!(PSSAP["U")
- Begin DoDot:2
- +15 SET PSSDD(PSSL_";"_PSSND)=$PIECE($GET(^PSDRUG(PSSL,0)),"^")
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ;
- ITEM(PSSIT,PSSDR) ;Return Orderable Item to CPRS
- +1 NEW PSSNEW
- +2 IF '$GET(PSSIT)!('$GET(PSSDR))
- QUIT -1
- +3 IF '$DATA(^PS(50.7,+$GET(PSSIT),0))!('$DATA(^PSDRUG(+$GET(PSSDR),0)))
- QUIT -1
- +4 SET PSSNEW=+$PIECE($GET(^PSDRUG(+$GET(PSSDR),2)),"^")
- +5 IF PSSNEW
- IF PSSNEW=$GET(PSSIT)
- QUIT 0
- +6 IF PSSNEW
- IF PSSNEW'=$GET(PSSIT)
- QUIT 1_"^"_PSSNEW
- +7 QUIT -1
- +8 ;
- +9 QUIT
- +10 ;
- EN1(PSSOA,PSSOAP) ;
- +1 ;Return Orderable Item Forumary Alternatives to CPRS
- +2 ;PSSOA = Pharmacy Orderable Item number
- +3 ;PSSOAP = "I" For Inpatient, "O" For Outpatient
- +4 IF '$GET(PSSOA)
- QUIT
- +5 IF $GET(PSSOAP)'="O"
- IF $GET(PSSOAP)'="I"
- QUIT
- +6 NEW PSSOAL,PSSOALD,PSSOAN,PSSOAIT,PSSOADT,PSSOAZ
- +7 SET PSSOAL=""
- FOR
- SET PSSOAL=$ORDER(^PSDRUG("ASP",PSSOA,PSSOAL))
- IF PSSOAL=""
- QUIT
- Begin DoDot:1
- +8 SET PSSOALD=""
- FOR
- SET PSSOALD=$ORDER(^PSDRUG(PSSOAL,65,PSSOALD))
- IF PSSOALD=""
- QUIT
- Begin DoDot:2
- +9 SET PSSOAN=$PIECE($GET(^PSDRUG(PSSOAL,65,PSSOALD,0)),"^")
- IF PSSOAN
- SET PSSOAIT=$PIECE($GET(^PSDRUG(PSSOAN,2)),"^")
- IF PSSOAIT
- Begin DoDot:3
- +10 IF PSSOAIT=PSSOA
- QUIT
- +11 IF $DATA(PSSOA(PSSOAIT))
- QUIT
- +12 IF '$DATA(^PS(50.7,PSSOAIT,0))!($PIECE($GET(^PS(50.7,PSSOAIT,0)),"^",12))
- QUIT
- +13 IF $PIECE($GET(^PS(50.7,PSSOAIT,0)),"^",4)&(+$PIECE($GET(^(0)),"^",4)'>DT)
- QUIT
- +14 SET PSSOAZ=""
- FOR
- SET PSSOAZ=$ORDER(^PSDRUG("ASP",PSSOAIT,PSSOAZ))
- IF PSSOAZ=""!($DATA(PSSOA(PSSOAIT)))
- QUIT
- Begin DoDot:4
- +15 IF $PIECE($GET(^PSDRUG(PSSOAZ,"I")),"^")&(+$PIECE($GET(^("I")),"^")'>DT)
- QUIT
- +16 IF $PIECE($GET(^PSDRUG(PSSOAZ,0)),"^",9)
- QUIT
- +17 IF $GET(PSSOAP)="O"
- IF $PIECE($GET(^PSDRUG(PSSOAZ,2)),"^",3)["O"
- SET PSSOA(PSSOAIT)=""
- QUIT
- +18 IF $PIECE($GET(^PSDRUG(PSSOAZ,2)),"^",3)["I"!($PIECE($GET(^(2)),"^",3)["U")
- SET PSSOA(PSSOAIT)=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 QUIT
- SCH(SCH) ;Expand schedule for Outpatient order in CPRS
- +1 NEW SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST,SCHEX
- +2 SET SCHEX=$GET(SCH)
- SET SQFLAG=0
- +3 IF $GET(SCH)=""
- GOTO SCHQT
- +4 ;I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
- +5 FOR SCLOOP=0:0
- SET SCLOOP=$ORDER(^PS(51.1,"B",SCH,SCLOOP))
- IF 'SCLOOP!(SQFLAG)
- QUIT
- IF $PIECE($GET(^PS(51.1,SCLOOP,0)),"^",8)'=""
- SET SCHEX=$PIECE($GET(^(0)),"^",8)
- SET SQFLAG=1
- +6 IF SQFLAG
- GOTO SCHQT
- +7 IF $PIECE($GET(^PS(51,"A",SCH)),"^")'=""
- SET SCHEX=$PIECE(^(SCH),"^")
- GOTO SCHQT
- +8 SET SCLOOP=0
- FOR SCLP=1:1:$LENGTH(SCH)
- SET SCLPS=$EXTRACT(SCH,SCLP)
- IF SCLPS=" "
- SET SCLOOP=SCLOOP+1
- +9 IF SCLOOP=0
- SET SCHEX=SCH
- GOTO SCHQT
- +10 SET SCLOOP=SCLOOP+1
- +11 KILL SCLHOLD
- FOR SCIN=1:1:SCLOOP
- SET (SODL,SCLHOLD(SCIN))=$PIECE(SCH," ",SCIN)
- Begin DoDot:1
- +12 IF $GET(SODL)=""
- QUIT
- +13 SET SQFLAG=0
- FOR SST=0:0
- SET SST=$ORDER(^PS(51.1,"B",SODL,SST))
- IF 'SST!($GET(SQFLAG))
- QUIT
- IF $PIECE($GET(^PS(51.1,SST,0)),"^",8)'=""
- SET SCLHOLD(SCIN)=$PIECE($GET(^(0)),"^",8)
- SET SQFLAG=1
- +14 IF $GET(SQFLAG)
- QUIT
- +15 IF $PIECE($GET(^PS(51,"A",SODL)),"^")'=""
- SET SCLHOLD(SCIN)=$PIECE(^(SODL),"^")
- End DoDot:1
- +16 SET SCHEX=""
- SET SQFLAG=0
- FOR SST=1:1:SCLOOP
- SET SCHEX=SCHEX_$SELECT($GET(SQFLAG):" ",1:"")_$GET(SCLHOLD(SST))
- SET SQFLAG=1
- SCHQT ;
- +1 SET SCH=SCHEX
- +2 QUIT
- +3 ;
- IVDEA(PSSIVOI,PSSIVOIP) ;DEA Special Handling to CPRS for IV Fluids dialogue
- +1 ;parameter 1 is Orderable Item
- +2 ;parameter 2 is "A" for Additive, "S" for Solution
- +3 ;Return variables: 1 - DEA contains a 1 or a 2
- +4 ;2 - DEA contains a 3, 4, or 5
- +5 ;0 - first 2 conditions not met, but active additive/solutions exist
- +6 ;null - no active additive/solution for the Orderable Item
- +7 NEW PSSIVDO,PSSIVDD,PSSIVL,PSSIVLP,PSSIVDEA,PSSIVLPX
- +8 SET (PSSIVDO,PSSIVDD)=0
- +9 IF $GET(PSSIVOIP)'="S"
- SET PSSIVOIP="A"
- +10 IF '$GET(PSSIVOI)
- GOTO IVQ
- +11 SET PSSIVL=""
- FOR
- SET PSSIVL=$ORDER(^PSDRUG("ASP",PSSIVOI,PSSIVL))
- IF PSSIVL=""!(PSSIVDO=1)
- QUIT
- Begin DoDot:1
- +12 IF $PIECE($GET(^PSDRUG(PSSIVL,"I")),"^")
- IF $PIECE($GET(^("I")),"^")<DT
- QUIT
- +13 IF $PIECE($GET(^PSDRUG(PSSIVL,2)),"^",3)'["I"
- IF $PIECE($GET(^(2)),"^",3)'["U"
- QUIT
- +14 IF PSSIVOIP="A"
- Begin DoDot:2
- +15 SET PSSIVLP=""
- SET PSSIVLPX=0
- FOR
- SET PSSIVLP=$ORDER(^PSDRUG("A526",PSSIVL,PSSIVLP))
- IF PSSIVLP=""!(PSSIVDO=1)!(PSSIVLPX)
- QUIT
- Begin DoDot:3
- +16 IF $DATA(^PS(52.6,PSSIVLP,0))
- IF '$PIECE($GET(^("I")),"^")!($PIECE($GET(^("I")),"^")>DT)
- SET (PSSIVDD,PSSIVLPX)=1
- DO IVX
- End DoDot:3
- End DoDot:2
- QUIT
- +17 SET PSSIVLP=""
- SET PSSIVLPX=0
- FOR
- SET PSSIVLP=$ORDER(^PSDRUG("A527",PSSIVL,PSSIVLP))
- IF PSSIVLP=""!(PSSIVDO=1)!(PSSIVLPX)
- QUIT
- Begin DoDot:2
- +18 IF $DATA(^PS(52.7,PSSIVLP,0))
- IF '$PIECE($GET(^("I")),"^")!($PIECE($GET(^("I")),"^")>DT)
- SET (PSSIVDD,PSSIVLPX)=1
- DO IVX
- End DoDot:2
- End DoDot:1
- IVQ ;
- +1 IF PSSIVDO=0
- IF 'PSSIVDD
- SET PSSIVDO=""
- +2 QUIT PSSIVDO
- +3 ;
- IVX ;
- +1 SET PSSIVDEA=$PIECE($GET(^PSDRUG(PSSIVL,0)),"^",3)
- +2 IF PSSIVDEA[1!(PSSIVDEA[2)
- SET PSSIVDO=1
- QUIT
- +3 IF PSSIVDEA[3!(PSSIVDEA[4)!(PSSIVDEA[5)
- SET PSSIVDO=2
- +4 QUIT
