- 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
