PSJPDV0 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ;10 Dec 98 / 8:21 AM
;;5.0; INPATIENT MEDICATIONS ;**12,22,33**;16 DEC 97
;
;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
;
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" UDSET D:PSJJORD["V" 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
;
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
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 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)
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
PSJPDV0 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ;10 Dec 98 / 8:21 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**12,22,33**;16 DEC 97
+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 ;
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"
DO UDSET
IF PSJJORD["V"
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 ;
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 SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
SET MR=$PIECE(ND,"^",3)
SET MR=$$ENMRN^PSGMI(MR)
+2 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_" "
+3 NEW X,PSJ
+4 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",30,0,.PSJ,1)
+5 SET DRG=PSJ(1)
+6 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
+7 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
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 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
+7 ;
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
