APSQCNDC.m

APSQCNDC ;IHS/ASD/ENM/POC - FINDS PROBLEM NDC NUMBERS IN DRUG FILE [ 11/21/2002  10:37 AM ]

 ;;6.0;OUTPATIENT PHARMACY;**3,4**;11/20/2002

 ;CHECK NDCS FOR DRUG FILE

 ;FORMAT IT FOR SCREEN OR PRINTER

 S %ZIS="" ;NO QUEUEING

 D ^%ZIS

 N APSQIEN,APSQNDC,DIV,CNT,CNTGOOD,CNTBAD,NOWRITE,HEAD,PAGE,END

 S (CNT,CNTGOOD,CNTBAD)=0

 S NOWRITE=0

 S U="^"

 S (END,PAGE)=0

 U IO D @("HDR"_(2-($E(IOST,1,2)="C-")))

 S APSQIEN=0 F  S APSQIEN=$O(^PSDRUG(APSQIEN)) Q:(APSQIEN'=+APSQIEN)!END  D

 .I $S('$D(^PSDRUG(+APSQIEN,"I")):0,DT'>^("I"):0,1:1) Q  ;INACTIVE

 .I $P(^PSDRUG(APSQIEN,0),U,1)["OUTSIDE DRUG" Q  ;DONT SHOW THIS ONE

 .;Q:$P($G(^PSDRUG(+APSQIEN,9999999)),U,3)'=+PSOSITE S DIV="FOR DIVISION "_$P(^PS(59,+PSOSITE,0),U,1) ;MUST BE SAME DIVISION PATCH 4

 .S APSQNDC=$P($G(^PSDRUG(+APSQIEN,2)),U,4)

 .D HDR:$Y+5>IOSL

 .S CNT=CNT+1

 .I 'APSQNDC W !,?2,$E($P(^PSDRUG(+APSQIEN,0),U,1),1,20),?25," (",+APSQIEN,")",?40,"HAS NO NDC" S CNTBAD=CNTBAD+1 Q

 .S X=APSQNDC D  I '$G(X) W !,?2,$E($P(^PSDRUG(+APSQIEN,0),U,1),1,20),?25," (",+APSQIEN,")",?40,"HAS INCORRECT FORMAT - ",APSQNDC S CNTBAD=CNTBAD+1 Q

 ..I X'?5N1"-"4N1"-"2N K X Q

 .S CNTGOOD=CNTGOOD+1

 Q:END

 S NOWRITE=1 D HDR ;SO WONT WRITE PART OF HEADER FOR THIS SEGMENT

 W !

 W !,?2,"DRUGS WITH APPROPRIATE NDC NUMBERS: "_$J(CNTGOOD,5)

 W !,?2,"DRUGS WITH PROBLEM NDC NUMBERS:     "_$J(CNTBAD,5)

 W !,?2,"                                    ","------"

 W !,?2,"TOTAL DRUGS COUNTED:                "_$J(CNT,5)

 D ^%ZISC ;NEED TO CLOSE IT DUMMY IHS/OKCAO/POC 8/14/2001

 Q

HDR ;HEADER

 I $E(IOST,1,2)="C-" W !,"PRESS RETURN TO CONTINUE OR '^' TO EXIT:  " R X:DTIME S END='$T!(X="^") Q:END

HDR1 W @IOF

HDR2 S PAGE=PAGE+1

 ;W ?20,"HEADING",?(IOM-10),"PAGE:  ",$J(PAGE,3)

 ;S AZODATE=$$FMTE^XLFDT(AZOBDT,"2")_"-"_$$FMTE^XLFDT(AZOEDT,"2")

 ;S AZOLOC=$P(^AUTTLOC(DUZ(2),0),"^",2)

 S HEAD="INAPPROPRIATE NDC NUMBERS FOR ACTIVE DRUGS"_$G(DIV)

 W ?(IOM-$L(HEAD)-2/2),HEAD,?(IOM-10),"PAGE:  ",$J(PAGE,3)

 W:'$G(NOWRITE) !,?2,"DRUG",?25,"NUMBER",?40,"PROBLEM"

 Q

APSQCNDC  ;IHS/ASD/ENM/POC - FINDS PROBLEM NDC NUMBERS IN DRUG FILE [ 11/21/2002  10:37 AM ]

 +1       ;;6.0;OUTPATIENT PHARMACY;**3,4**;11/20/2002

 +2       ;CHECK NDCS FOR DRUG FILE

 +3       ;FORMAT IT FOR SCREEN OR PRINTER

 +4       ;NO QUEUEING

           SET %ZIS=""

 +5        DO ^%ZIS

 +6        NEW APSQIEN,APSQNDC,DIV,CNT,CNTGOOD,CNTBAD,NOWRITE,HEAD,PAGE,END

 +7        SET (CNT,CNTGOOD,CNTBAD)=0

 +8        SET NOWRITE=0

 +9        SET U="^"

 +10       SET (END,PAGE)=0

 +11       USE IO

           DO @("HDR"_(2-($EXTRACT(IOST,1,2)="C-")))

 +12       SET APSQIEN=0

           FOR 

               SET APSQIEN=$ORDER(^PSDRUG(APSQIEN))

               IF (APSQIEN'=+APSQIEN)!END

                   QUIT 

               Begin DoDot:1

 +13      ;INACTIVE

                   IF $SELECT('$DATA(^PSDRUG(+APSQIEN,"I")):0,DT'>^("I"):0,1:1)

                       QUIT 

 +14      ;DONT SHOW THIS ONE

                   IF $PIECE(^PSDRUG(APSQIEN,0),U,1)["OUTSIDE DRUG"

                       QUIT 

 +15      ;Q:$P($G(^PSDRUG(+APSQIEN,9999999)),U,3)'=+PSOSITE S DIV="FOR DIVISION "_$P(^PS(59,+PSOSITE,0),U,1) ;MUST BE SAME DIVISION PATCH 4

 +16               SET APSQNDC=$PIECE($GET(^PSDRUG(+APSQIEN,2)),U,4)

 +17               IF $Y+5>IOSL

                       DO HDR

 +18               SET CNT=CNT+1

 +19               IF 'APSQNDC

                       WRITE !,?2,$EXTRACT($PIECE(^PSDRUG(+APSQIEN,0),U,1),1,20),?25," (",+APSQIEN,")",?40,"HAS NO NDC"

                       SET CNTBAD=CNTBAD+1

                       QUIT 

 +20               SET X=APSQNDC

                   Begin DoDot:2

 +21                   IF X'?5N1"-"4N1"-"2N

                           KILL X

                           QUIT 

                   End DoDot:2

                   IF '$GET(X)

                       WRITE !,?2,$EXTRACT($PIECE(^PSDRUG(+APSQIEN,0),U,1),1,20),?25," (",+APSQIEN,")",?40,"HAS INCORRECT FORMAT - ",APSQNDC

                       SET CNTBAD=CNTBAD+1

                       QUIT 

 +22               SET CNTGOOD=CNTGOOD+1

               End DoDot:1

 +23       IF END

               QUIT 

 +24      ;SO WONT WRITE PART OF HEADER FOR THIS SEGMENT

           SET NOWRITE=1

           DO HDR

 +25       WRITE !

 +26       WRITE !,?2,"DRUGS WITH APPROPRIATE NDC NUMBERS: "_$JUSTIFY(CNTGOOD,5)

 +27       WRITE !,?2,"DRUGS WITH PROBLEM NDC NUMBERS:     "_$JUSTIFY(CNTBAD,5)

 +28       WRITE !,?2,"                                    ","------"

 +29       WRITE !,?2,"TOTAL DRUGS COUNTED:                "_$JUSTIFY(CNT,5)

 +30      ;NEED TO CLOSE IT DUMMY IHS/OKCAO/POC 8/14/2001

           DO ^%ZISC

 +31       QUIT 

HDR       ;HEADER

 +1        IF $EXTRACT(IOST,1,2)="C-"

               WRITE !,"PRESS RETURN TO CONTINUE OR '^' TO EXIT:  "

               READ X:DTIME

               SET END='$TEST!(X="^")

               IF END

                   QUIT 

HDR1       WRITE @IOF

HDR2       SET PAGE=PAGE+1

 +1       ;W ?20,"HEADING",?(IOM-10),"PAGE:  ",$J(PAGE,3)

 +2       ;S AZODATE=$$FMTE^XLFDT(AZOBDT,"2")_"-"_$$FMTE^XLFDT(AZOEDT,"2")

 +3       ;S AZOLOC=$P(^AUTTLOC(DUZ(2),0),"^",2)

 +4        SET HEAD="INAPPROPRIATE NDC NUMBERS FOR ACTIVE DRUGS"_$GET(DIV)

 +5        WRITE ?(IOM-$LENGTH(HEAD)-2/2),HEAD,?(IOM-10),"PAGE:  ",$JUSTIFY(PAGE,3)

 +6        IF '$GET(NOWRITE)

               WRITE !,?2,"DRUG",?25,"NUMBER",?40,"PROBLEM"

 +7        QUIT