PSJPDV0 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ; 7/6/09 2:20pm
;;5.0;INPATIENT MEDICATIONS;**12,22,33,214,380,396**;16 DEC 97;Build 1
;
;Reference to ^PS(52.6 is supported by DBIA 1231
;Reference to ^PS(52.7 is supported by DBIA 2173
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^SC is supported by DBIA 10040
;Reference to ^DG(40.8 is supported by DBIA 728
;Reference to ^DIC(42 is supported by DBIA 1377
;
ENQ N TMPWD,TMPRB D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT
K ^TMP("PSJ",$J),^TMP("PSJPDV",$J)
D:CHOICE'="IV" UDORD D:CHOICE'="UD" IVORD
I $D(PMATCH) S PSGP=0 F S PSGP=$O(PMATCH(PSGP)) Q:'PSGP D GETMAT I MATCHES'<PSJMAT&($D(^TMP("PSJPDV",$J,+PSGP))) D
.S PSJACNWP=1 D ^PSJAC S TMPWD=PSJPWDN,TMPRB=PSJPRB,NM=PSGP(0),PSJJORD=0 F S PSJJORD=$O(^TMP("PSJPDV",$J,PSGP,PSJJORD)) Q:'PSJJORD D:PSJJORD'["V"&$$DIVWARD UDSET D:PSJJORD["V"&$$DIVWARD IVSET
D ^PSJPDV1
;
DONE K ^TMP("PSJ",$J),^TMP("PSJPDV",$J),%,ADD,CHOICE,CLS,DFN,DO,DRG,IVDO,IVDRG,IVIR,IVMR,IVND,IVORD,IVPSGP,IVSCH,IVSPD,IVSTD,MR,ND,ND2,NM,PATDRG,PDRG,PMATCH,PSGDT,PSGP,PSJJORD,SCH,SOL,SPD,SPPDRG,STD,VA,VADM,VAIN
Q
;
DIVWARD() ;DIVISION/WARD MATCH FOR PATIENT (PSJ*5*214)
N PSJV,PSJVA,PSJVC
S PSJVA=0
I $G(VAUTD) I $G(VAUTW) Q 1 ;ALL DIVISIONS/ALL WARDS
I $D(VAUTW(PSJPWD)) Q 1 ;SPECIFIC WARD MATCHES
I '$G(VAUTD),'$G(PSJPWD) Q 1 ;specific division & no ward. Elimination will be at order level (CLN label)
I $G(VAUTW) D Q PSJVA ;SPECIFIC DIVISION MATCHES
. S PSJVC=0 F S PSJVC=$O(VAUTD(PSJVC)) Q:PSJVC'=+PSJVC S PSJV=VAUTD(PSJVC) I $G(PSJPWD) I PSJV=$P($G(^DG(40.8,+$P($G(^DIC(42,(+PSJPWD),0)),"^",11),0)),U,1) S PSJVA=1
Q 0
;
UDORD ;find all Unit Dose orders with specified dispense drugs
S SPD=$P(PSJREPS,".")-.0001 F S SPD=$O(^PS(55,"AUD",SPD)) Q:'SPD S PSGP=0 F S PSGP=$O(^PS(55,"AUD",SPD,PSGP)) Q:'PSGP D
.S PSJJORD=0 F S PSJJORD=$O(^PS(55,"AUD",SPD,PSGP,PSJJORD)) Q:'PSJJORD D
..S ND=$G(^PS(55,PSGP,5,PSJJORD,2)) I +$P(ND,U,2)=0!(+$P(ND,U,2)>PSJREPF) Q
..Q:'$O(^PS(55,PSGP,5,PSJJORD,1,0))
..S PDRG=0 F S PDRG=$O(^PS(55,PSGP,5,PSJJORD,1,PDRG)) Q:+PDRG=0 S SPPDRG=+$P(^(PDRG,0),"^") I $D(PSJISP(SPPDRG_"D")) S ^TMP("PSJPDV",$J,PSGP,PSJJORD)=SPD,CLS=PSJISP(SPPDRG_"D"),$P(PMATCH(PSGP),U,+CLS)=+CLS
Q
;
UDSET ;get patient and order information and set in global
N CLN,SC0
I '$G(VAUTD),'$G(PSJPWD) S CLN=+$P($G(^PS(55,PSGP,5,PSJJORD,8)),U) Q:'CLN S SC0=+$P($G(^SC(CLN,0)),U,15) Q:'$$CLN(SC0)
S ND=$G(^PS(55,PSGP,5,PSJJORD,0)),MR=$P(ND,"^",3),MR=$$ENMRN^PSGMI(MR)
S ND=$G(^PS(55,PSGP,5,PSJJORD,2)),DRG=$G(^(.2)),SCH=$P(ND,"^"),SPD=^TMP("PSJPDV",$J,PSGP,PSJJORD),STD=$S($P(ND,"^",2):$P(ND,"^",2),1:"NOT FOUND"),DO=$P(DRG,"^",2),DRG=$$ENPDN^PSGMI($P(DRG,"^")) I DO]"",$E(DO,$L(DO))'=" " S DO=DO_" "
N X,PSJ
D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",30,0,.PSJ,1)
S DRG=PSJ(1)
S ^TMP("PSJ",$J,$S(PSJSRT="P":NM_";"_DFN,1:+$G(STD)),$S(PSJSRT="P":+$G(STD),1:NM_";"_DFN),PSJJORD)=VA("PID")_"^"_PSJPWDN_"^"_PSJPRB_"^"_DRG_"^"_DO_MR_" "_SCH_"^"_SPD
Q
IVORD ;get IV orders matching the requested drug
S IVSPD=$P(PSJREPS,".")-.0001 F S IVSPD=$O(^PS(55,"AIV",IVSPD)) Q:'IVSPD S IVPSGP=0 F S IVPSGP=$O(^PS(55,"AIV",IVSPD,IVPSGP)) Q:'IVPSGP D
.S IVORD=0 F S IVORD=$O(^PS(55,"AIV",IVSPD,IVPSGP,IVORD)) Q:'IVORD D
..S ND=$G(^PS(55,IVPSGP,"IV",IVORD,0)) I +$P(ND,U,2)=0!(+$P(ND,U,2)>PSJREPF) Q
..D MATADD,MATSOL
Q
MATADD ;see if additives of the order match the drug
Q:'$O(^PS(55,IVPSGP,"IV",IVORD,"AD",0))
S ADD=0 F S ADD=$O(^PS(55,IVPSGP,"IV",IVORD,"AD",ADD)) Q:'ADD S ND=$G(^(ADD,0)),ND2=$G(^PS(52.6,+$P(ND,"^"),0)) D
.I ND2]"" I $D(PSJISP($S(PSJSL="O":+$P($G(ND2),U,11)_"O",1:+$P($G(ND2),U,2)_"D"))) S CLS=PSJISP($S(PSJSL="O":$P(ND2,"^",11)_"O",1:$P(ND2,"^",2)_"D")),$P(PMATCH(IVPSGP),U,+CLS)=+CLS,^TMP("PSJPDV",$J,IVPSGP,IVORD_"V")=IVSPD
Q
MATSOL ;see if solutions of the order match the drug
Q:'$O(^PS(55,IVPSGP,"IV",IVORD,"SOL",0))
S SOL=0 F S SOL=$O(^PS(55,IVPSGP,"IV",IVORD,"SOL",SOL)) Q:'SOL S ND=$G(^(SOL,0)),ND2=$G(^PS(52.7,+$P(ND,"^"),0)) D
.I ND2]"" I $D(PSJISP($S(PSJSL="O":+$P($G(ND2),U,11)_"O",1:+$P($G(ND2),U,2)_"D"))) S CLS=PSJISP($S(PSJSL="O":$P(ND2,"^",11)_"O",1:$P(ND2,"^",2)_"D")),$P(PMATCH(IVPSGP),U,+CLS)=+CLS,^TMP("PSJPDV",$J,IVPSGP,IVORD_"V")=IVSPD
Q
;
IVSET ;S IVND=$G(^PS(55,PSGP,"IV",+PSJJORD,0)),IVSCH=$P(IVND,"^",9),IVSTD=$P(IVND,"^",2),IVSPD=^TMP("PSJPDV",$J,PSGP,PSJJORD),IVMR=$P($G(^PS(55,PSGP,"IV",+PSJJORD,6)),"^",3),IVIR=$P(IVND,"^",8)
;S IVMR=$$ENMRN^PSGMI(IVMR)
;S IVDRG=$G(^PS(55,PSGP,"IV",+PSJJORD,6)),IVDO=$P(IVDRG,"^",2),IVDRG=$$ENPDN^PSGMI($P(IVDRG,"^")) I IVDO]"",$E(IVDO,$L(IVDO))'=" " S IVDO=IVDO_" "
N X,ON55,CLN,SC0 S DFN=PSGP,ON=PSJJORD D GT55^PSIVORFB
S DRG=$S($D(DRG("AD",1)):$P(DRG("AD",1),U,2),1:$P(DRG("SOL",1),U,2)),IVSCH=P(9),IVSTD=P(2),IVSPD=^TMP("PSJPDV",$J,PSGP,PSJJORD),IVMR=$P(P("MR"),U,2),IVIR=P(8),IVDRG=DRG
S PSJPWDN=$S($G(^PS(55,PSGP,"IV",+ON,"DSS")):$P($G(^SC(+$G(^PS(55,PSGP,"IV",+ON,"DSS")),0)),"^"),($G(PSJPDD)]""&(IVSTD>+PSJPDD)):"",1:TMPWD),PSJPRB=$S($G(^PS(55,PSGP,"IV",+ON,"DSS")):"",($G(PSJPDD)]""&(IVSTD>+PSJPDD)):"",1:TMPRB)
I '$G(VAUTD),'$G(PSJPWD) S CLN=+$P($G(^PS(55,PSGP,"IV",+ON,"DSS")),"^") Q:'CLN S SC0=+$P($G(^SC(CLN,0)),U,15) Q:'$$CLN(SC0)
S ^TMP("PSJ",$J,$S(PSJSRT="P":NM_";"_DFN,1:+$G(IVSTD)),$S(PSJSRT="P":+$G(IVSTD),1:NM_";"_DFN),PSJJORD)=VA("PID")_"^"_PSJPWDN_"^"_PSJPRB_"^"_IVDRG_"^"_IVMR_" "_IVSCH_" "_IVIR_"^"_IVSPD
;
GETMAT ;see if the patient has the number of drugs necessary to be printed on
;the report
S MATCHES=0 F GG=1:1:$L(PMATCH(PSGP),"^") S GGG=$P(PMATCH(PSGP),"^",GG) S:GGG MATCHES=MATCHES+1
Q
;
CLN(SDIV) ; check Out patient clinic orders
N DIV,FLG,PSJVC
I 'SDIV Q 0
S FLG=0 I SDIV>0 S DIV=$P(^DG(40.8,SDIV,0),U)
I DIV]"" S PSJVC=0 F S PSJVC=$O(VAUTD(PSJVC)) Q:PSJVC'=+PSJVC S PSJV=VAUTD(PSJVC) I PSJV=DIV S FLG=1 Q
Q FLG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDV0 5883 printed Nov 22, 2024@17:18:58 Page 2
PSJPDV0 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ; 7/6/09 2:20pm
+1 ;;5.0;INPATIENT MEDICATIONS;**12,22,33,214,380,396**;16 DEC 97;Build 1
+2 ;
+3 ;Reference to ^PS(52.6 is supported by DBIA 1231
+4 ;Reference to ^PS(52.7 is supported by DBIA 2173
+5 ;Reference to ^PS(55 is supported by DBIA 2191
+6 ;Reference to ^SC is supported by DBIA 10040
+7 ;Reference to ^DG(40.8 is supported by DBIA 728
+8 ;Reference to ^DIC(42 is supported by DBIA 1377
+9 ;
ENQ NEW TMPWD,TMPRB
DO NOW^%DTC
SET PSGDT=%
SET DT=$$DT^XLFDT
+1 KILL ^TMP("PSJ",$JOB),^TMP("PSJPDV",$JOB)
+2 if CHOICE'="IV"
DO UDORD
if CHOICE'="UD"
DO IVORD
+3 IF $DATA(PMATCH)
SET PSGP=0
FOR
SET PSGP=$ORDER(PMATCH(PSGP))
if 'PSGP
QUIT
DO GETMAT
IF MATCHES'<PSJMAT&($DATA(^TMP("PSJPDV",$JOB,+PSGP)))
Begin DoDot:1
+4 SET PSJACNWP=1
DO ^PSJAC
SET TMPWD=PSJPWDN
SET TMPRB=PSJPRB
SET NM=PSGP(0)
SET PSJJORD=0
FOR
SET PSJJORD=$ORDER(^TMP("PSJPDV",$JOB,PSGP,PSJJORD))
if 'PSJJORD
QUIT
if PSJJORD'["V"&$$DIVWARD
DO UDSET
if PSJJORD["V"&$$DIVWARD
DO IVSET
End DoDot:1
+5 DO ^PSJPDV1
+6 ;
DONE KILL ^TMP("PSJ",$JOB),^TMP("PSJPDV",$JOB),%,ADD,CHOICE,CLS,DFN,DO,DRG,IVDO,IVDRG,IVIR,IVMR,IVND,IVORD,IVPSGP,IVSCH,IVSPD,IVSTD,MR,ND,ND2,NM,PATDRG,PDRG,PMATCH,PSGDT,PSGP,PSJJORD,SCH,SOL,SPD,SPPDRG,STD,VA,VADM,VAIN
+1 QUIT
+2 ;
DIVWARD() ;DIVISION/WARD MATCH FOR PATIENT (PSJ*5*214)
+1 NEW PSJV,PSJVA,PSJVC
+2 SET PSJVA=0
+3 ;ALL DIVISIONS/ALL WARDS
IF $GET(VAUTD)
IF $GET(VAUTW)
QUIT 1
+4 ;SPECIFIC WARD MATCHES
IF $DATA(VAUTW(PSJPWD))
QUIT 1
+5 ;specific division & no ward. Elimination will be at order level (CLN label)
IF '$GET(VAUTD)
IF '$GET(PSJPWD)
QUIT 1
+6 ;SPECIFIC DIVISION MATCHES
IF $GET(VAUTW)
Begin DoDot:1
+7 SET PSJVC=0
FOR
SET PSJVC=$ORDER(VAUTD(PSJVC))
if PSJVC'=+PSJVC
QUIT
SET PSJV=VAUTD(PSJVC)
IF $GET(PSJPWD)
IF PSJV=$PIECE($GET(^DG(40.8,+$PIECE($GET(^DIC(42,(+PSJPWD),0)),"^",11),0)),U,1)
SET PSJVA=1
End DoDot:1
QUIT PSJVA
+8 QUIT 0
+9 ;
UDORD ;find all Unit Dose orders with specified dispense drugs
+1 SET SPD=$PIECE(PSJREPS,".")-.0001
FOR
SET SPD=$ORDER(^PS(55,"AUD",SPD))
if 'SPD
QUIT
SET PSGP=0
FOR
SET PSGP=$ORDER(^PS(55,"AUD",SPD,PSGP))
if 'PSGP
QUIT
Begin DoDot:1
+2 SET PSJJORD=0
FOR
SET PSJJORD=$ORDER(^PS(55,"AUD",SPD,PSGP,PSJJORD))
if 'PSJJORD
QUIT
Begin DoDot:2
+3 SET ND=$GET(^PS(55,PSGP,5,PSJJORD,2))
IF +$PIECE(ND,U,2)=0!(+$PIECE(ND,U,2)>PSJREPF)
QUIT
+4 if '$ORDER(^PS(55,PSGP,5,PSJJORD,1,0))
QUIT
+5 SET PDRG=0
FOR
SET PDRG=$ORDER(^PS(55,PSGP,5,PSJJORD,1,PDRG))
if +PDRG=0
QUIT
SET SPPDRG=+$PIECE(^(PDRG,0),"^")
IF $DATA(PSJISP(SPPDRG_"D"))
SET ^TMP("PSJPDV",$JOB,PSGP,PSJJORD)=SPD
SET CLS=PSJISP(SPPDRG_"D")
SET $PIECE(PMATCH(PSGP),U,+CLS)=+CLS
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
UDSET ;get patient and order information and set in global
+1 NEW CLN,SC0
+2 IF '$GET(VAUTD)
IF '$GET(PSJPWD)
SET CLN=+$PIECE($GET(^PS(55,PSGP,5,PSJJORD,8)),U)
if 'CLN
QUIT
SET SC0=+$PIECE($GET(^SC(CLN,0)),U,15)
if '$$CLN(SC0)
QUIT
+3 SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
SET MR=$PIECE(ND,"^",3)
SET MR=$$ENMRN^PSGMI(MR)
+4 SET ND=$GET(^PS(55,PSGP,5,PSJJORD,2))
SET DRG=$GET(^(.2))
SET SCH=$PIECE(ND,"^")
SET SPD=^TMP("PSJPDV",$JOB,PSGP,PSJJORD)
SET STD=$SELECT($PIECE(ND,"^",2):$PIECE(ND,"^",2),1:"NOT FOUND")
SET DO=$PIECE(DRG,"^",2)
SET DRG=$$ENPDN^PSGMI($PIECE(DRG,"^"))
IF DO]""
IF $EXTRACT(DO,$LENGTH(DO))'=" "
SET DO=DO_" "
+5 NEW X,PSJ
+6 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",30,0,.PSJ,1)
+7 SET DRG=PSJ(1)
+8 SET ^TMP("PSJ",$JOB,$SELECT(PSJSRT="P":NM_";"_DFN,1:+$GET(STD)),$SELECT(PSJSRT="P":+$GET(STD),1:NM_";"_DFN),PSJJORD)=VA("PID")_"^"_PSJPWDN_"^"_PSJPRB_"^"_DRG_"^"_DO_MR_" "_SCH_"^"_SPD
+9 QUIT
IVORD ;get IV orders matching the requested drug
+1 SET IVSPD=$PIECE(PSJREPS,".")-.0001
FOR
SET IVSPD=$ORDER(^PS(55,"AIV",IVSPD))
if 'IVSPD
QUIT
SET IVPSGP=0
FOR
SET IVPSGP=$ORDER(^PS(55,"AIV",IVSPD,IVPSGP))
if 'IVPSGP
QUIT
Begin DoDot:1
+2 SET IVORD=0
FOR
SET IVORD=$ORDER(^PS(55,"AIV",IVSPD,IVPSGP,IVORD))
if 'IVORD
QUIT
Begin DoDot:2
+3 SET ND=$GET(^PS(55,IVPSGP,"IV",IVORD,0))
IF +$PIECE(ND,U,2)=0!(+$PIECE(ND,U,2)>PSJREPF)
QUIT
+4 DO MATADD
DO MATSOL
End DoDot:2
End DoDot:1
+5 QUIT
MATADD ;see if additives of the order match the drug
+1 if '$ORDER(^PS(55,IVPSGP,"IV",IVORD,"AD",0))
QUIT
+2 SET ADD=0
FOR
SET ADD=$ORDER(^PS(55,IVPSGP,"IV",IVORD,"AD",ADD))
if 'ADD
QUIT
SET ND=$GET(^(ADD,0))
SET ND2=$GET(^PS(52.6,+$PIECE(ND,"^"),0))
Begin DoDot:1
+3 IF ND2]""
IF $DATA(PSJISP($SELECT(PSJSL="O":+$PIECE($GET(ND2),U,11)_"O",1:+$PIECE($GET(ND2),U,2)_"D")))
SET CLS=PSJISP($SELECT(PSJSL="O":$PIECE(ND2,"^",11)_"O",1:$PIECE(ND2,"^",2)_"D"))
SET $PIECE(PMATCH(IVPSGP),U,+CLS)=+CLS
SET ^TMP("PSJPDV",$JOB,IVPSGP,IVORD_"V")=IVSPD
End DoDot:1
+4 QUIT
MATSOL ;see if solutions of the order match the drug
+1 if '$ORDER(^PS(55,IVPSGP,"IV",IVORD,"SOL",0))
QUIT
+2 SET SOL=0
FOR
SET SOL=$ORDER(^PS(55,IVPSGP,"IV",IVORD,"SOL",SOL))
if 'SOL
QUIT
SET ND=$GET(^(SOL,0))
SET ND2=$GET(^PS(52.7,+$PIECE(ND,"^"),0))
Begin DoDot:1
+3 IF ND2]""
IF $DATA(PSJISP($SELECT(PSJSL="O":+$PIECE($GET(ND2),U,11)_"O",1:+$PIECE($GET(ND2),U,2)_"D")))
SET CLS=PSJISP($SELECT(PSJSL="O":$PIECE(ND2,"^",11)_"O",1:$PIECE(ND2,"^",2)_"D"))
SET $PIECE(PMATCH(IVPSGP),U,+CLS)=+CLS
SET ^TMP("PSJPDV",$JOB,IVPSGP,IVORD_"V")=IVSPD
End DoDot:1
+4 QUIT
+5 ;
IVSET ;S IVND=$G(^PS(55,PSGP,"IV",+PSJJORD,0)),IVSCH=$P(IVND,"^",9),IVSTD=$P(IVND,"^",2),IVSPD=^TMP("PSJPDV",$J,PSGP,PSJJORD),IVMR=$P($G(^PS(55,PSGP,"IV",+PSJJORD,6)),"^",3),IVIR=$P(IVND,"^",8)
+1 ;S IVMR=$$ENMRN^PSGMI(IVMR)
+2 ;S IVDRG=$G(^PS(55,PSGP,"IV",+PSJJORD,6)),IVDO=$P(IVDRG,"^",2),IVDRG=$$ENPDN^PSGMI($P(IVDRG,"^")) I IVDO]"",$E(IVDO,$L(IVDO))'=" " S IVDO=IVDO_" "
+3 NEW X,ON55,CLN,SC0
SET DFN=PSGP
SET ON=PSJJORD
DO GT55^PSIVORFB
+4 SET DRG=$SELECT($DATA(DRG("AD",1)):$PIECE(DRG("AD",1),U,2),1:$PIECE(DRG("SOL",1),U,2))
SET IVSCH=P(9)
SET IVSTD=P(2)
SET IVSPD=^TMP("PSJPDV",$JOB,PSGP,PSJJORD)
SET IVMR=$PIECE(P("MR"),U,2)
SET IVIR=P(8)
SET IVDRG=DRG
+5 SET PSJPWDN=$SELECT($GET(^PS(55,PSGP,"IV",+ON,"DSS")):$PIECE($GET(^SC(+$GET(^PS(55,PSGP,"IV",+ON,"DSS")),0)),"^"),($GET(PSJPDD)]""&(IVSTD>+PSJPDD)):"",1:TMPWD)
SET PSJPRB=$SELECT($GET(^PS(55,PSGP,"IV",+ON,"DSS")):"",($GET(PSJPDD)]""&(IVSTD>+PSJPDD)):"",1:TMPRB)
+6 IF '$GET(VAUTD)
IF '$GET(PSJPWD)
SET CLN=+$PIECE($GET(^PS(55,PSGP,"IV",+ON,"DSS")),"^")
if 'CLN
QUIT
SET SC0=+$PIECE($GET(^SC(CLN,0)),U,15)
if '$$CLN(SC0)
QUIT
+7 SET ^TMP("PSJ",$JOB,$SELECT(PSJSRT="P":NM_";"_DFN,1:+$GET(IVSTD)),$SELECT(PSJSRT="P":+$GET(IVSTD),1:NM_";"_DFN),PSJJORD)=VA("PID")_"^"_PSJPWDN_"^"_PSJPRB_"^"_IVDRG_"^"_IVMR_" "_IVSCH_" "_IVIR_"^"_IVSPD
+8 ;
GETMAT ;see if the patient has the number of drugs necessary to be printed on
+1 ;the report
+2 SET MATCHES=0
FOR GG=1:1:$LENGTH(PMATCH(PSGP),"^")
SET GGG=$PIECE(PMATCH(PSGP),"^",GG)
if GGG
SET MATCHES=MATCHES+1
+3 QUIT
+4 ;
CLN(SDIV) ; check Out patient clinic orders
+1 NEW DIV,FLG,PSJVC
+2 IF 'SDIV
QUIT 0
+3 SET FLG=0
IF SDIV>0
SET DIV=$PIECE(^DG(40.8,SDIV,0),U)
+4 IF DIV]""
SET PSJVC=0
FOR
SET PSJVC=$ORDER(VAUTD(PSJVC))
if PSJVC'=+PSJVC
QUIT
SET PSJV=VAUTD(PSJVC)
IF PSJV=DIV
SET FLG=1
QUIT
+5 QUIT FLG
