PSANDC ;BIR/LTL-NDC Duplicates Report ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
;This routine checks the ITEM FILE for multiple NDC's.
;
;References to $$DESCR^PRCPUX1 are covered by IA #259
;References to $$VENNAME^PRCPUX1 are covered by IA #259
;References to ^PRC( are covered by IA #214
F I=0:1:4 W !,$P($T(NAR+I),";;",2,99)
NAR ;Expanation
;; This report lists each National Drug Code (NDC) that has been
;; entered for more than one item. In order for the DRUG file to
;; correctly link to the ITEM MASTER file, it is recommended that the NDC
;; be removed from all but the one correct entry.
D DT^DICRW
DEV ;asks device and queueing info
K I,IO("Q") N %ZIS,DTOUT,DUOUT,IOP,POP,PSAOUT S %ZIS="Q" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" S PSAOUT=1 G END
I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSANDC",ZTDESC="Duplicate NDC Report" D ^%ZTLOAD,HOME^%ZIS S PSAOUT=1 G END
START ;compiles and prints data for report
N %DT,DIR,DIRUT,PSAPG,PSANDC,PSALN,PSANDCD,PSARPDT,X,Y S (PSANDC,PSANDCD)="",(PSAPG,PSAOUT)=0,Y=DT D DD^%DT S PSARPDT=Y D HEADER
LOOP F S PSANDC=$O(^PRC(441,"F",PSANDC)) G:PSANDC=""!(PSAOUT) END D:$Y+10>IOSL HEADER D G:PSAOUT END
.S PSANDC(1)=0
.F S PSANDCD=$O(^PRC(441,"F",PSANDC,PSANDCD)) Q:'PSANDCD!(PSAOUT) I $O(^PRC(441,"F",PSANDC,PSANDCD)),'$G(^PRC(441,+PSANDCD,3)),'$G(^PRC(441,+$O(^PRC(441,"F",PSANDC,PSANDCD)),3)) D D:$Y+10>IOSL HEADER Q:PSAOUT
..S PSANDC(1)=PSANDC(1)+1
..W:PSANDC(1)=1 !,PSALN,!,?30,"NDC: "_PSANDC,!!,"ITEM #",?10,"DESCRIPTION",?50,"VENDOR",!!,PSANDCD,?10,$E($$DESCR^PRCPUX1(0,PSANDCD),1,37),?50,$E($$VENNAME^PRCPUX1($O(^PRC(441,"F",PSANDC,PSANDCD,0))_"PRC(440"),1,30)
..W !!,$O(^PRC(441,"F",PSANDC,PSANDCD)),?10,$E($$DESCR^PRCPUX1(0,$O(^PRC(441,"F",PSANDC,PSANDCD))),1,37),?50,$E($$VENNAME^PRCPUX1($O(^PRC(441,"F",PSANDC,$O(^PRC(441,"F",PSANDC,PSANDCD)),0))_"PRC(440"),1,30)
END I $E(IOST)'="C" W @IOF
I $E(IOST,1,2)="C-",'$G(PSAOUT) W !! S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
Q
I $E(IOST,1,2)'="P-",PSAPG S DIR(0)="E" D ^DIR K DIR I 'Y S PSAOUT=1 Q
I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSAOUT=1 Q
W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1 W !?2,"DUPLICATE NDC REPORT",?35,PSARPDT,?70,"PAGE: "_PSAPG,!,!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSANDC 2504 printed Oct 16, 2024@17:50:34 Page 2
PSANDC ;BIR/LTL-NDC Duplicates Report ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
+2 ;This routine checks the ITEM FILE for multiple NDC's.
+3 ;
+4 ;References to $$DESCR^PRCPUX1 are covered by IA #259
+5 ;References to $$VENNAME^PRCPUX1 are covered by IA #259
+6 ;References to ^PRC( are covered by IA #214
+7 FOR I=0:1:4
WRITE !,$PIECE($TEXT(NAR+I),";;",2,99)
NAR ;Expanation
+1 ;; This report lists each National Drug Code (NDC) that has been
+2 ;; entered for more than one item. In order for the DRUG file to
+3 ;; correctly link to the ITEM MASTER file, it is recommended that the NDC
+4 ;; be removed from all but the one correct entry.
+5 DO DT^DICRW
DEV ;asks device and queueing info
+1 KILL I,IO("Q")
NEW %ZIS,DTOUT,DUOUT,IOP,POP,PSAOUT
SET %ZIS="Q"
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
SET PSAOUT=1
GOTO END
+2 IF $DATA(IO("Q"))
NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="START^PSANDC"
SET ZTDESC="Duplicate NDC Report"
DO ^%ZTLOAD
DO HOME^%ZIS
SET PSAOUT=1
GOTO END
START ;compiles and prints data for report
+1 NEW %DT,DIR,DIRUT,PSAPG,PSANDC,PSALN,PSANDCD,PSARPDT,X,Y
SET (PSANDC,PSANDCD)=""
SET (PSAPG,PSAOUT)=0
SET Y=DT
DO DD^%DT
SET PSARPDT=Y
DO HEADER
LOOP FOR
SET PSANDC=$ORDER(^PRC(441,"F",PSANDC))
if PSANDC=""!(PSAOUT)
GOTO END
if $Y+10>IOSL
DO HEADER
Begin DoDot:1
+1 SET PSANDC(1)=0
+2 FOR
SET PSANDCD=$ORDER(^PRC(441,"F",PSANDC,PSANDCD))
if 'PSANDCD!(PSAOUT)
QUIT
IF $ORDER(^PRC(441,"F",PSANDC,PSANDCD))
IF '$GET(^PRC(441,+PSANDCD,3))
IF '$GET(^PRC(441,+$ORDER(^PRC(441,"F",PSANDC,PSANDCD)),3))
Begin DoDot:2
+3 SET PSANDC(1)=PSANDC(1)+1
+4 if PSANDC(1)=1
WRITE !,PSALN,!,?30,"NDC: "_PSANDC,!!,"ITEM #",?10,"DESCRIPTION",?50,"VENDOR",!!,PSANDCD,?10,$EXTRACT($$DESCR^PRCPUX1(0,PSANDCD),1,37),?50,$EXTRACT($$VENNAME^PRCPUX1($ORDER(^PRC(441,"F",PSANDC,PSANDCD,0))_"PRC(4
40"),1,30)
+5 WRITE !!,$ORDER(^PRC(441,"F",PSANDC,PSANDCD)),?10,$EXTRACT($$DESCR^PRCPUX1(0,$ORDER(^PRC(441,"F",PSANDC,PSANDCD))),1,37),?50,$EXTRACT($$VENNAME^PRCPUX1($ORDER(^PRC(441,"F",PSANDC,$ORDER(^PRC(441,"F",PSANDC,PSANDCD)),
0))_"PRC(440"),1,30)
End DoDot:2
if $Y+10>IOSL
DO HEADER
if PSAOUT
QUIT
End DoDot:1
if PSAOUT
GOTO END
END IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF '$GET(PSAOUT)
WRITE !!
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu."
DO ^DIR
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
+3 QUIT
+1 IF $EXTRACT(IOST,1,2)'="P-"
IF PSAPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
QUIT
+2 IF $$S^%ZTLOAD
WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U),"."
SET PSAOUT=1
QUIT
+3 if $Y
WRITE @IOF
SET $PIECE(PSALN,"-",81)=""
SET PSAPG=PSAPG+1
WRITE !?2,"DUPLICATE NDC REPORT",?35,PSARPDT,?70,"PAGE: "_PSAPG,!,!!
+4 QUIT
