- QAMC24 ;ISC7/LJA,DAD-CONDITION: PATIENTS WITH 2+ RXS FOR SAME DRUG CLASS ;9/3/93 13:22
- ;;1.0;Clinical Monitoring System;;09/13/1993
- EN1 ; *** CONDITION CODE
- S QAMDCL=$S($D(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:+^("P1"),1:0)
- ;
- F QAMID=QAMTODAY-.0000001:0 S QAMID=$O(^PSRX("AD",QAMID)) Q:(QAMID'>0)!(QAMID>(QAMTODAY+.9999999))!(QAMID\1'?7N) D
- . F QAMRXN=0:0 S QAMRXN=$O(^PSRX("AD",+QAMID,QAMRXN)) Q:QAMRXN'>0 D
- .. S QAMRX0=$G(^PSRX(QAMRXN,0)),QAMDFN=+$P(QAMRX0,U,2)
- .. Q:('$P(QAMRX0,U,6))!('QAMDFN) ; No drug / patient
- .. Q:"^11^12^13^"[("^"_$P(QAMRX0,"^",15)_"^") ; Status
- .. S QA=+$P($G(^PSDRUG(+$P(QAMRX0,U,6),"ND")),U,6) ; Class
- .. Q:$O(^QA(743.5,QAMDCL,"GRP","AB",QA,0))'>0
- .. S QAMEXP=QAMTODAY
- .. F S QAMEXP=$O(^PS(55,QAMDFN,"P","A",QAMEXP)) Q:QAMEXP'>0 F QAMRXD0=0:0 S QAMRXD0=$O(^PS(55,QAMDFN,"P","A",QAMEXP,QAMRXD0)) Q:QAMRXD0'>0 D
- ... Q:QAMRXN=QAMRXD0
- ... S QAMRX0=$G(^PSRX(QAMRXD0,0))
- ... Q:'$P(QAMRX0,U,6) ; No drug found
- ... Q:"^11^12^13^"[("^"_$P(QAMRX0,"^",15)_"^") ; Status
- ... S QA=+$P($G(^PSDRUG(+$P(QAMRX0,U,6),"ND")),U,6) ; Class
- ... Q:$O(^QA(743.5,QAMDCL,"GRP","AB",QA,0))'>0
- ... S ^UTILITY($J,"QAM CONDITION",QAMD1,QAMDFN)=""
- ... S ^UTILITY($J,"QAM CONDITION",QAMD1,QAMDFN,QAMID)=QAMRXN
- ... Q
- .. Q
- . Q
- K QAMDCL,QAMEXP,QAMRX0,QAMRXD0,QAMRXN
- Q
- ;
- EN2 ; *** PARAMETER CODE
- K DIC,DIR,DIRUT
- S DIC=743.5,DIC(0)="EMNQZ",DIC("A")="DRUG CLASS GROUP: "
- S DIC("B")=$P($G(^QA(743,QAMD0,"COND",QAMD1,"P1")),"^",2)
- K:DIC("B")="" DIC("B")
- S DIC("S")="I $P(^QA(743.5,+Y,0),""^"",2)=50.605"
- S DIC("W")="W "" "",$P(^(0),""^"",2)"
- S DIR("?",1)="Enter the DRUG CLASS group you wish to monitor. All 'TODAY-1'"
- S DIR("?")="fills will be scanned for duplicate fills for this group."
- S QAMPARAM="P1" D EN2^QAMUTL1 I $D(DIRUT) S Y=-1 G Y
- S:Y]"" ^QA(743,QAMD0,"COND",QAMD1,"P1")=+Y_"^"_Y(0,0)
- ;
- EXIT K Y
- K QAMPARAM
- Y Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMC24 1904 printed Mar 13, 2025@20:46:48 Page 2
- QAMC24 ;ISC7/LJA,DAD-CONDITION: PATIENTS WITH 2+ RXS FOR SAME DRUG CLASS ;9/3/93 13:22
- +1 ;;1.0;Clinical Monitoring System;;09/13/1993
- EN1 ; *** CONDITION CODE
- +1 SET QAMDCL=$SELECT($DATA(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:+^("P1"),1:0)
- +2 ;
- +3 FOR QAMID=QAMTODAY-.0000001:0
- SET QAMID=$ORDER(^PSRX("AD",QAMID))
- if (QAMID'>0)!(QAMID>(QAMTODAY+.9999999))!(QAMID\1'?7N)
- QUIT
- Begin DoDot:1
- +4 FOR QAMRXN=0:0
- SET QAMRXN=$ORDER(^PSRX("AD",+QAMID,QAMRXN))
- if QAMRXN'>0
- QUIT
- Begin DoDot:2
- +5 SET QAMRX0=$GET(^PSRX(QAMRXN,0))
- SET QAMDFN=+$PIECE(QAMRX0,U,2)
- +6 ; No drug / patient
- if ('$PIECE(QAMRX0,U,6))!('QAMDFN)
- QUIT
- +7 ; Status
- if "^11^12^13^"[("^"_$PIECE(QAMRX0,"^",15)_"^")
- QUIT
- +8 ; Class
- SET QA=+$PIECE($GET(^PSDRUG(+$PIECE(QAMRX0,U,6),"ND")),U,6)
- +9 if $ORDER(^QA(743.5,QAMDCL,"GRP","AB",QA,0))'>0
- QUIT
- +10 SET QAMEXP=QAMTODAY
- +11 FOR
- SET QAMEXP=$ORDER(^PS(55,QAMDFN,"P","A",QAMEXP))
- if QAMEXP'>0
- QUIT
- FOR QAMRXD0=0:0
- SET QAMRXD0=$ORDER(^PS(55,QAMDFN,"P","A",QAMEXP,QAMRXD0))
- if QAMRXD0'>0
- QUIT
- Begin DoDot:3
- +12 if QAMRXN=QAMRXD0
- QUIT
- +13 SET QAMRX0=$GET(^PSRX(QAMRXD0,0))
- +14 ; No drug found
- if '$PIECE(QAMRX0,U,6)
- QUIT
- +15 ; Status
- if "^11^12^13^"[("^"_$PIECE(QAMRX0,"^",15)_"^")
- QUIT
- +16 ; Class
- SET QA=+$PIECE($GET(^PSDRUG(+$PIECE(QAMRX0,U,6),"ND")),U,6)
- +17 if $ORDER(^QA(743.5,QAMDCL,"GRP","AB",QA,0))'>0
- QUIT
- +18 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAMDFN)=""
- +19 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAMDFN,QAMID)=QAMRXN
- +20 QUIT
- End DoDot:3
- +21 QUIT
- End DoDot:2
- +22 QUIT
- End DoDot:1
- +23 KILL QAMDCL,QAMEXP,QAMRX0,QAMRXD0,QAMRXN
- +24 QUIT
- +25 ;
- EN2 ; *** PARAMETER CODE
- +1 KILL DIC,DIR,DIRUT
- +2 SET DIC=743.5
- SET DIC(0)="EMNQZ"
- SET DIC("A")="DRUG CLASS GROUP: "
- +3 SET DIC("B")=$PIECE($GET(^QA(743,QAMD0,"COND",QAMD1,"P1")),"^",2)
- +4 if DIC("B")=""
- KILL DIC("B")
- +5 SET DIC("S")="I $P(^QA(743.5,+Y,0),""^"",2)=50.605"
- +6 SET DIC("W")="W "" "",$P(^(0),""^"",2)"
- +7 SET DIR("?",1)="Enter the DRUG CLASS group you wish to monitor. All 'TODAY-1'"
- +8 SET DIR("?")="fills will be scanned for duplicate fills for this group."
- +9 SET QAMPARAM="P1"
- DO EN2^QAMUTL1
- IF $DATA(DIRUT)
- SET Y=-1
- GOTO Y
- +10 if Y]""
- SET ^QA(743,QAMD0,"COND",QAMD1,"P1")=+Y_"^"_Y(0,0)
- +11 ;
- EXIT KILL Y
- +1 KILL QAMPARAM
- Y QUIT
