APSPCTR1 ; IHS/DSD/ENM - CONTROLLED DRUG REPORT PRINTOUT ;11-Nov-2009 10:11;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1008**;Sep 23, 2004
;THIS ROUTINE PRINTS THE PHARMACY CONTROLLED DRUG LISTING
;IT IS CALLED BY ^APSPCTR
;Modified - IHS/MSC/PLS - 12/30/08 - Patch 1008 - Routine updated
Q
PRINT ;EP
N APSPPG,DFLG,NEWPG,DPARTIAL,TPARTIAL,DNEW,DREFILL,APSPGT,APSPT
S (APSPPG,DFLG,NEWPG,APSPGT)=0
S (DCOUNT,TCOUNT,DNEW,TNEW,DREFILL,DPARTIAL,TPARTIAL,TREFILL,TQTY)=0
D PRINT1
W:'DFLG !,"No data found..."
Q
;
PRINT1 ;EP
N DIV,SUB1,SUB2,SUB3,SUB4,SUB5,VAL,LP,LSTFDT,APSPSH
S LSTFDT=0
S APSP(2)=0,APSP("3-5")=0,(APSPT(2),APSPT(35))=0
S DIV=0 F S DIV=$O(^TMP($J,"XREF",DIV)) Q:'DIV D
.D HDR
.I APSPDTDR=2 D ; Drug Name
..S SUB1="" F S SUB1=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1)) Q:SUB1="" D ; Drug Name
...S SUB2="" F S SUB2=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2)) Q:SUB2="" D ; Drug Class
....S APSPSH=SUB2
....S SUB3=0 F S SUB3=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3)) Q:'SUB3 D ; Fill Date
.....S SUB4=0 F S SUB4=$O(^TMP($J,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3,SUB4)) Q:'SUB4 D ; Data Node
......D PRINT2(^TMP($J,"DATA",SUB4))
......S DFLG=1
......D TOTALS
....D SUB2
..D DIVSUB
.E D ; Fill Date
..S SUB1=0 F S SUB1=$O(^TMP($J,"XREF",DIV,"FDT",SUB1)) Q:'SUB1 D ; Fill Date
...S SUB2="" F S SUB2=$O(^TMP($J,"XREF",DIV,"FDT",SUB1,SUB2)) Q:SUB2="" D ; Drug Class
....S APSPSH=SUB2
....S SUB3="" F S SUB3=$O(^TMP($J,"XREF",DIV,"FDT",SUB1,SUB2,SUB3)) Q:SUB3="" D ; Data Name
.....S SUB4=0 F S SUB4=$O(^TMP($J,"XREF",DIV,"FDT",SUB1,SUB2,SUB3,SUB4)) Q:'SUB4 D ; Data Node
......D PRINT2(^TMP($J,"DATA",SUB4))
......S DFLG=1
......D TOTALS
....D SUB
..D DIVSUB1
Q
; Print the line
PRINT2(DATA) ; EP -
N RX,DFN,HRN
S RX=+DATA
S DFN=$$GET1^DIQ(52,RX,2,"I")
S HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
S TQTY=TQTY+$P(DATA,U,6)
S DCOUNT=DCOUNT+1
I $P(DATA,U,3)="ADP" D
.S DPARTIAL=DPARTIAL+1
E D
.I $P(DATA,U,4) D
..S DREFILL=DREFILL+1
.E S DNEW=DNEW+1
; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
;Format: Prescription IEN^Fill Date^Xref ("AD" or "ADP")^Fill SubIEN^Prescription Number^QTY^Drug Class^Drug Name^Fill Type^RI Flg^Drug IEN^RX Division^Days Supply^Prescriber^Pharmacist^Clerk
W !,$P(DATA,U,5),?15,$P(DATA,U,8),?57,$P(DATA,U,6),?64,$$GET1^DIQ(200,$P(DATA,U,14),.01),?83,$$FMTE^XLFDT($P(DATA,U,2),"5Z"),?98,$E($$GET1^DIQ(2,DFN,.01),1,18),?118,HRN,?127,$$GET1^DIQ(200,$P(DATA,U,16),1)
D PRINT3 ;check page length
Q
; Check page length and optionally print blank line
;
PRINT3 ;EP
D:$Y+8>IOSL HDR
Q
;Date order loop
LOOP F APSPD=0:0 S APSPD=$O(^TMP("APSP",$J,APSPDIV,APSPD)) Q:APSPD="" F APSPSH=0:0 S APSPSH=$O(^TMP("APSP",$J,APSPDIV,APSPD,APSPSH)) Q:'APSPSH D LOOP1,SUB
Q
LOOP1 F APSPDR=0:0 S APSPDR=$O(^TMP("APSP",$J,APSPDIV,APSPD,APSPSH,APSPDR)) Q:'APSPDR F APSPN=0:0 S APSPN=$O(^TMP("APSP",$J,APSPDIV,APSPD,APSPSH,APSPDR,APSPN)) Q:'APSPN D PRINT,TOTALS
Q
;Drug order loop
LOP F APSPDR=0:0 S APSPDR=$O(^TMP("APSP",$J,APSPDIV,APSPDR)) Q:APSPDR="" F APSPSH=0:0 S APSPSH=$O(^TMP("APSP",$J,APSPDIV,APSPDR,APSPSH)) Q:'APSPSH D LOP1,SUB2
Q
LOP1 F APSPD=0:0 S APSPD=$O(^TMP("APSP",$J,APSPDIV,APSPDR,APSPSH,APSPD)) Q:'APSPD F APSPN=0:0 S APSPN=$O(^TMP("APSP",$J,APSPDIV,APSPDR,APSPSH,APSPD,APSPN)) Q:'APSPN D PRINT,TOTALS
Q
DIVSUB ;PRINT TOTAL PRESCRIPTIONS/REFILLS
W ! F I=1:1:IOM W "-"
W !,"TOTAL # OF PRESCRIPTIONS : ",APSPGT
W ?($X+5),"TOTAL # NEW RX'S : ",TNEW
W ?($X+5),"TOTAL # REFILLS : ",TREFILL
W ?($X+5),"TOTAL # PARTIALS : ",TPARTIAL
S (APSP("PAGE"),APSPGT,TNEW,TREFILL,TPARTIAL)=0
I $E(IOST,1,2)="P-" W !,@IOF
Q
DIVSUB1 ;PRINT TOTAL SPECIAL HANDLING CODES
W ! F I=1:1:IOM W "-"
W !,"TOTAL # OF PRESCRIPTIONS : ",APSPGT
W ?($X+5),"TOTAL # CODE 2's : ",APSPT(2)
W ?($X+5),"TOTAL # CODES 3-5 : ",APSPT(35)
S (APSP("PAGE"),APSPT(2),APSPT(35),APSPGT)=0
I $E(IOST,1,2)="P-" W !,@IOF
Q
SUB ;W ! F I=1:1:43 W "-"
S APSP("2")=0,APSP("3-5")=0
Q
SUB2 W ! F I=1:1:43 W "-"
W !,"SUB-TOTAL # OF RX's : ",TCOUNT
W ?($X+5),"TOTAL QTY : ",TQTY,!
S TCOUNT=0,TQTY=0
Q
TOTALS ;
I APSPDTDR=1,"345"[+APSPSH S APSP("3-5")=APSP("3-5")+1,APSPT(35)=APSPT(35)+1
I APSPDTDR=1,+APSPSH=2 S APSP(2)=APSP(2)+1,APSPT(2)=APSPT(2)+1
S TCOUNT=TCOUNT+DCOUNT,APSPGT=APSPGT+DCOUNT,DCOUNT=0
S TNEW=TNEW+DNEW,DNEW=0
S TREFILL=TREFILL+DREFILL,DREFILL=0
S TPARTIAL=TPARTIAL+DPARTIAL,DPARTIAL=0
Q
HDR ;EP
W @IOF
S APSPPG=APSPPG+1
S APSPDV=$P(^PS(59,DIV,0),U)
W !!,APSPDV," CONTROLLED DRUG USE LIST (By ",$S(APSPDTDR=1:"DATE",APSPDTDR=2:"Drug",1:"")_" Order)"
W ?73,"Page ",APSPPG
W !,"DATE OF LISTING: "
W $$FMTE^XLFDT($$DT^XLFDT(),"5Z")
W !,"Drug Class: "_APSPDCTN(APSPDCLS)
K X,Y
I APSPDIV="*" W !,"All Divisions for: ",$P(^DIC(4,DUZ(2),0),U,1)
W !,"Division: ",$G(APSPDV)
W !!,"This list will include all Prescriptions for any controlled"
W " medications dispensed from "
W APSPBDF," through ",APSPEDF,!!
W !!,"RX #",?13,"DRUG",?57,"QTY",?64,"PHYSICIAN"
W ?83,"DATE FILLED",?98,"PATIENT",?118,"CHART #",?127,"CLERK"
W ! F I=1:1:IOM W "-"
I '$D(^TMP($J,"DATA")) W !!?20,"NO PATIENTS RECEIVED MEDICATION"
W !
Q
APSPCTR1 ; IHS/DSD/ENM - CONTROLLED DRUG REPORT PRINTOUT ;11-Nov-2009 10:11;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1008**;Sep 23, 2004
+2 ;THIS ROUTINE PRINTS THE PHARMACY CONTROLLED DRUG LISTING
+3 ;IT IS CALLED BY ^APSPCTR
+4 ;Modified - IHS/MSC/PLS - 12/30/08 - Patch 1008 - Routine updated
+5 QUIT
PRINT ;EP
+1 NEW APSPPG,DFLG,NEWPG,DPARTIAL,TPARTIAL,DNEW,DREFILL,APSPGT,APSPT
+2 SET (APSPPG,DFLG,NEWPG,APSPGT)=0
+3 SET (DCOUNT,TCOUNT,DNEW,TNEW,DREFILL,DPARTIAL,TPARTIAL,TREFILL,TQTY)=0
+4 DO PRINT1
+5 IF 'DFLG
WRITE !,"No data found..."
+6 QUIT
+7 ;
PRINT1 ;EP
+1 NEW DIV,SUB1,SUB2,SUB3,SUB4,SUB5,VAL,LP,LSTFDT,APSPSH
+2 SET LSTFDT=0
+3 SET APSP(2)=0
SET APSP("3-5")=0
SET (APSPT(2),APSPT(35))=0
+4 SET DIV=0
FOR
SET DIV=$ORDER(^TMP($JOB,"XREF",DIV))
IF 'DIV
QUIT
Begin DoDot:1
+5 DO HDR
+6 ; Drug Name
IF APSPDTDR=2
Begin DoDot:2
+7 ; Drug Name
SET SUB1=""
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1))
IF SUB1=""
QUIT
Begin DoDot:3
+8 ; Drug Class
SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2))
IF SUB2=""
QUIT
Begin DoDot:4
+9 SET APSPSH=SUB2
+10 ; Fill Date
SET SUB3=0
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3))
IF 'SUB3
QUIT
Begin DoDot:5
+11 ; Data Node
SET SUB4=0
FOR
SET SUB4=$ORDER(^TMP($JOB,"XREF",DIV,"DRUG",SUB1,SUB2,SUB3,SUB4))
IF 'SUB4
QUIT
Begin DoDot:6
+12 DO PRINT2(^TMP($JOB,"DATA",SUB4))
+13 SET DFLG=1
+14 DO TOTALS
End DoDot:6
End DoDot:5
+15 DO SUB2
End DoDot:4
End DoDot:3
+16 DO DIVSUB
End DoDot:2
+17 ; Fill Date
IF '$TEST
Begin DoDot:2
+18 ; Fill Date
SET SUB1=0
FOR
SET SUB1=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1))
IF 'SUB1
QUIT
Begin DoDot:3
+19 ; Drug Class
SET SUB2=""
FOR
SET SUB2=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1,SUB2))
IF SUB2=""
QUIT
Begin DoDot:4
+20 SET APSPSH=SUB2
+21 ; Data Name
SET SUB3=""
FOR
SET SUB3=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1,SUB2,SUB3))
IF SUB3=""
QUIT
Begin DoDot:5
+22 ; Data Node
SET SUB4=0
FOR
SET SUB4=$ORDER(^TMP($JOB,"XREF",DIV,"FDT",SUB1,SUB2,SUB3,SUB4))
IF 'SUB4
QUIT
Begin DoDot:6
+23 DO PRINT2(^TMP($JOB,"DATA",SUB4))
+24 SET DFLG=1
+25 DO TOTALS
End DoDot:6
End DoDot:5
+26 DO SUB
End DoDot:4
End DoDot:3
+27 DO DIVSUB1
End DoDot:2
End DoDot:1
+28 QUIT
+29 ; Print the line
PRINT2(DATA) ; EP -
+1 NEW RX,DFN,HRN
+2 SET RX=+DATA
+3 SET DFN=$$GET1^DIQ(52,RX,2,"I")
+4 SET HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
+5 SET TQTY=TQTY+$PIECE(DATA,U,6)
+6 SET DCOUNT=DCOUNT+1
+7 IF $PIECE(DATA,U,3)="ADP"
Begin DoDot:1
+8 SET DPARTIAL=DPARTIAL+1
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 IF $PIECE(DATA,U,4)
Begin DoDot:2
+11 SET DREFILL=DREFILL+1
End DoDot:2
+12 IF '$TEST
SET DNEW=DNEW+1
End DoDot:1
+13 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+14 ;Format: Prescription IEN^Fill Date^Xref ("AD" or "ADP")^Fill SubIEN^Prescription Number^QTY^Drug Class^Drug Name^Fill Type^RI Flg^Drug IEN^RX Division^Days Supply^Prescriber^Pharmacist^Clerk
+15 WRITE !,$PIECE(DATA,U,5),?15,$PIECE(DATA,U,8),?57,$PIECE(DATA,U,6),?64,$$GET1^DIQ(200,$PIECE(DATA,U,14),.01),?83,$$FMTE^XLFDT($PIECE(DATA,U,2),"5Z"),?98,$EXTRACT($$GET1^DIQ(2,DFN,.01),1,18),?118,HRN,?127,$$GET1^DIQ(200,$PIECE(DATA,U,16),1)
+16 ;check page length
DO PRINT3
+17 QUIT
+18 ; Check page length and optionally print blank line
+19 ;
PRINT3 ;EP
+1 IF $Y+8>IOSL
DO HDR
+2 QUIT
+3 ;Date order loop
LOOP FOR APSPD=0:0
SET APSPD=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPD))
IF APSPD=""
QUIT
FOR APSPSH=0:0
SET APSPSH=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPD,APSPSH))
IF 'APSPSH
QUIT
DO LOOP1
DO SUB
+1 QUIT
LOOP1 FOR APSPDR=0:0
SET APSPDR=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPD,APSPSH,APSPDR))
IF 'APSPDR
QUIT
FOR APSPN=0:0
SET APSPN=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPD,APSPSH,APSPDR,APSPN))
IF 'APSPN
QUIT
DO PRINT
DO TOTALS
+1 QUIT
+2 ;Drug order loop
LOP FOR APSPDR=0:0
SET APSPDR=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPDR))
IF APSPDR=""
QUIT
FOR APSPSH=0:0
SET APSPSH=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPDR,APSPSH))
IF 'APSPSH
QUIT
DO LOP1
DO SUB2
+1 QUIT
LOP1 FOR APSPD=0:0
SET APSPD=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPDR,APSPSH,APSPD))
IF 'APSPD
QUIT
FOR APSPN=0:0
SET APSPN=$ORDER(^TMP("APSP",$JOB,APSPDIV,APSPDR,APSPSH,APSPD,APSPN))
IF 'APSPN
QUIT
DO PRINT
DO TOTALS
+1 QUIT
DIVSUB ;PRINT TOTAL PRESCRIPTIONS/REFILLS
+1 WRITE !
FOR I=1:1:IOM
WRITE "-"
+2 WRITE !,"TOTAL # OF PRESCRIPTIONS : ",APSPGT
+3 WRITE ?($X+5),"TOTAL # NEW RX'S : ",TNEW
+4 WRITE ?($X+5),"TOTAL # REFILLS : ",TREFILL
+5 WRITE ?($X+5),"TOTAL # PARTIALS : ",TPARTIAL
+6 SET (APSP("PAGE"),APSPGT,TNEW,TREFILL,TPARTIAL)=0
+7 IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
+8 QUIT
DIVSUB1 ;PRINT TOTAL SPECIAL HANDLING CODES
+1 WRITE !
FOR I=1:1:IOM
WRITE "-"
+2 WRITE !,"TOTAL # OF PRESCRIPTIONS : ",APSPGT
+3 WRITE ?($X+5),"TOTAL # CODE 2's : ",APSPT(2)
+4 WRITE ?($X+5),"TOTAL # CODES 3-5 : ",APSPT(35)
+5 SET (APSP("PAGE"),APSPT(2),APSPT(35),APSPGT)=0
+6 IF $EXTRACT(IOST,1,2)="P-"
WRITE !,@IOF
+7 QUIT
SUB ;W ! F I=1:1:43 W "-"
+1 SET APSP("2")=0
SET APSP("3-5")=0
+2 QUIT
SUB2 WRITE !
FOR I=1:1:43
WRITE "-"
+1 WRITE !,"SUB-TOTAL # OF RX's : ",TCOUNT
+2 WRITE ?($X+5),"TOTAL QTY : ",TQTY,!
+3 SET TCOUNT=0
SET TQTY=0
+4 QUIT
TOTALS ;
+1 IF APSPDTDR=1
IF "345"[+APSPSH
SET APSP("3-5")=APSP("3-5")+1
SET APSPT(35)=APSPT(35)+1
+2 IF APSPDTDR=1
IF +APSPSH=2
SET APSP(2)=APSP(2)+1
SET APSPT(2)=APSPT(2)+1
+3 SET TCOUNT=TCOUNT+DCOUNT
SET APSPGT=APSPGT+DCOUNT
SET DCOUNT=0
+4 SET TNEW=TNEW+DNEW
SET DNEW=0
+5 SET TREFILL=TREFILL+DREFILL
SET DREFILL=0
+6 SET TPARTIAL=TPARTIAL+DPARTIAL
SET DPARTIAL=0
+7 QUIT
HDR ;EP
+1 WRITE @IOF
+2 SET APSPPG=APSPPG+1
+3 SET APSPDV=$PIECE(^PS(59,DIV,0),U)
+4 WRITE !!,APSPDV," CONTROLLED DRUG USE LIST (By ",$SELECT(APSPDTDR=1:"DATE",APSPDTDR=2:"Drug",1:"")_" Order)"
+5 WRITE ?73,"Page ",APSPPG
+6 WRITE !,"DATE OF LISTING: "
+7 WRITE $$FMTE^XLFDT($$DT^XLFDT(),"5Z")
+8 WRITE !,"Drug Class: "_APSPDCTN(APSPDCLS)
+9 KILL X,Y
+10 IF APSPDIV="*"
WRITE !,"All Divisions for: ",$PIECE(^DIC(4,DUZ(2),0),U,1)
+11 WRITE !,"Division: ",$GET(APSPDV)
+12 WRITE !!,"This list will include all Prescriptions for any controlled"
+13 WRITE " medications dispensed from "
+14 WRITE APSPBDF," through ",APSPEDF,!!
+15 WRITE !!,"RX #",?13,"DRUG",?57,"QTY",?64,"PHYSICIAN"
+16 WRITE ?83,"DATE FILLED",?98,"PATIENT",?118,"CHART #",?127,"CLERK"
+17 WRITE !
FOR I=1:1:IOM
WRITE "-"
+18 IF '$DATA(^TMP($JOB,"DATA"))
WRITE !!?20,"NO PATIENTS RECEIVED MEDICATION"
+19 WRITE !
+20 QUIT
