PSNCMOP ;BIR/DMA&WRT-print products marked for CMOP ; 12/26/13 14:33
;;4.0;NATIONAL DRUG FILE;**3,365**;30 Oct 98;Build 9
PRELIM W !,"This report will print out all VA Product Names marked for CMOP transmission.",!,"You may either sort by VA Product Name or by VA Identifier.",!
W "This information comes from the VA Products file (NATIONALLY MARKED).",!,?15,"*** This is a long report ***",!,"You may queue the report to print, if you wish.",!!
K DIR S DIR(0)="SA^I:IDENTIFIER;N:NAME",DIR("A")="Sort by VA Identifier (I) or VA Product Name (N)? " D ^DIR G END:$D(DIRUT) S S=Y
S ZTSAVE("S")="" D EN^XUTMDEVQ("GO^PSNCMOP","PRINT DRUGS MARKED FOR CMOP",.ZTSAVE) I POP W !,"No device selected",!
END K DIR,S,X,Y,ZTSAVE,^TMP($J,"PSN") Q
;
GO ;ENTRY POINT
K ^TMP($J,"PSN") D @S
S:$D(ZTQUEUED) ZTREQ="@" K DA,DIR,ID,LINE,NA,PG,PR,S,TD,UN,X0,X1,Y,^TMP($J) D ^%ZISC Q
;
I ;SORT BY ID
S DA=0 F S DA=$O(^PSNDF(50.68,DA)) Q:'DA S X0=^(DA,0),X1=^(1) I $P(X1,"^",3) S ID=$P(X1,"^",2),NA=$P(X0,"^",1),UN=$P(X1,"^",4),UN=$P($G(^PSNDF(50.64,+UN,0)),"^"),^TMP($J,"PSN",ID,NA,UN)=""
S PG=1,TD=$TR($$HTE^XLFDT($H),"@"," "),$P(LINE,"-",IOM-1)="" D HEADID
S ID="" F S ID=$O(^TMP($J,"PSN",ID)),NA="" Q:ID="" F S NA=$O(^TMP($J,"PSN",ID,NA)),UN="" Q:NA="" F S UN=$O(^TMP($J,"PSN",ID,NA,UN)) Q:UN="" W !,ID,?10,NA,?60,UN I $Y+4>IOSL D HEADID
Q
;
HEADID W:$Y @IOF W !,?12,"VA PRODUCT LIST",?IOM-35," ",TD," PAGE ",PG,!,"ID#",?10,"VA PRINT NAME",?55,"VA DISP UNIT",!,LINE,! S PG=PG+1 Q
;
;
N ;SORT BY NAME
S DA=0 F S DA=$O(^PSNDF(50.68,DA)) Q:'DA S X0=^(DA,0),X1=^(1) I $P(X1,"^",3) S NA=$P(X0,"^"),PR=$P(X1,"^"),UN=$P(X1,"^",4),UN=$P($G(^PSNDF(50.64,+UN,0)),"^"),ID=$P(X1,"^",2),^TMP($J,"PSN",NA,PR,UN,ID)=""
S PG=1,TD=$TR($$HTE^XLFDT($H),"@"," "),$P(LINE,"-",IOM-1)="" D HEADNA
S NA="" F S NA=$O(^TMP($J,"PSN",NA)),PR="" Q:NA="" F S PR=$O(^TMP($J,"PSN",NA,PR)),UN="" Q:PR="" F S UN=$O(^TMP($J,"PSN",NA,PR,UN)),ID="" Q:UN="" F S ID=$O(^TMP($J,"PSN",NA,PR,UN,ID)) Q:ID="" D
.W !,NA,!,?7,PR,?60,UN,?70,ID I $Y+4>IOSL D HEADNA
Q
;
HEADNA W:$Y @IOF W !,?12,"VA PRODUCT LIST",?IOM-35," ",TD," PAGE ",PG,!,"VA PRODUCT NAME",!,?5,"VA PRINT NAME",?55,"VA DISP UNIT",?70,"ID#",!,LINE,! S PG=PG+1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNCMOP 2231 printed Sep 23, 2025@19:59:50 Page 2
PSNCMOP ;BIR/DMA&WRT-print products marked for CMOP ; 12/26/13 14:33
+1 ;;4.0;NATIONAL DRUG FILE;**3,365**;30 Oct 98;Build 9
PRELIM WRITE !,"This report will print out all VA Product Names marked for CMOP transmission.",!,"You may either sort by VA Product Name or by VA Identifier.",!
+1 WRITE "This information comes from the VA Products file (NATIONALLY MARKED).",!,?15,"*** This is a long report ***",!,"You may queue the report to print, if you wish.",!!
+2 KILL DIR
SET DIR(0)="SA^I:IDENTIFIER;N:NAME"
SET DIR("A")="Sort by VA Identifier (I) or VA Product Name (N)? "
DO ^DIR
if $DATA(DIRUT)
GOTO END
SET S=Y
+3 SET ZTSAVE("S")=""
DO EN^XUTMDEVQ("GO^PSNCMOP","PRINT DRUGS MARKED FOR CMOP",.ZTSAVE)
IF POP
WRITE !,"No device selected",!
END KILL DIR,S,X,Y,ZTSAVE,^TMP($JOB,"PSN")
QUIT
+1 ;
GO ;ENTRY POINT
+1 KILL ^TMP($JOB,"PSN")
DO @S
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL DA,DIR,ID,LINE,NA,PG,PR,S,TD,UN,X0,X1,Y,^TMP($JOB)
DO ^%ZISC
QUIT
+3 ;
I ;SORT BY ID
+1 SET DA=0
FOR
SET DA=$ORDER(^PSNDF(50.68,DA))
if 'DA
QUIT
SET X0=^(DA,0)
SET X1=^(1)
IF $PIECE(X1,"^",3)
SET ID=$PIECE(X1,"^",2)
SET NA=$PIECE(X0,"^",1)
SET UN=$PIECE(X1,"^",4)
SET UN=$PIECE($GET(^PSNDF(50.64,+UN,0)),"^")
SET ^TMP($JOB,"PSN",ID,NA,UN)=""
+2 SET PG=1
SET TD=$TRANSLATE($$HTE^XLFDT($HOROLOG),"@"," ")
SET $PIECE(LINE,"-",IOM-1)=""
DO HEADID
+3 SET ID=""
FOR
SET ID=$ORDER(^TMP($JOB,"PSN",ID))
SET NA=""
if ID=""
QUIT
FOR
SET NA=$ORDER(^TMP($JOB,"PSN",ID,NA))
SET UN=""
if NA=""
QUIT
FOR
SET UN=$ORDER(^TMP($JOB,"PSN",ID,NA,UN))
if UN=""
QUIT
WRITE !,ID,?10,NA,?60,UN
IF $Y+4>IOSL
DO HEADID
+4 QUIT
+5 ;
HEADID if $Y
WRITE @IOF
WRITE !,?12,"VA PRODUCT LIST",?IOM-35," ",TD," PAGE ",PG,!,"ID#",?10,"VA PRINT NAME",?55,"VA DISP UNIT",!,LINE,!
SET PG=PG+1
QUIT
+1 ;
+2 ;
N ;SORT BY NAME
+1 SET DA=0
FOR
SET DA=$ORDER(^PSNDF(50.68,DA))
if 'DA
QUIT
SET X0=^(DA,0)
SET X1=^(1)
IF $PIECE(X1,"^",3)
SET NA=$PIECE(X0,"^")
SET PR=$PIECE(X1,"^")
SET UN=$PIECE(X1,"^",4)
SET UN=$PIECE($GET(^PSNDF(50.64,+UN,0)),"^")
SET ID=$PIECE(X1,"^",2)
SET ^TMP($JOB,"PSN",NA,PR,UN,ID)=""
+2 SET PG=1
SET TD=$TRANSLATE($$HTE^XLFDT($HOROLOG),"@"," ")
SET $PIECE(LINE,"-",IOM-1)=""
DO HEADNA
+3 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,"PSN",NA))
SET PR=""
if NA=""
QUIT
FOR
SET PR=$ORDER(^TMP($JOB,"PSN",NA,PR))
SET UN=""
if PR=""
QUIT
FOR
SET UN=$ORDER(^TMP($JOB,"PSN",NA,PR,UN))
SET ID=""
if UN=""
QUIT
FOR
SET ID=$ORDER(^TMP($JOB,"PSN",NA,PR,UN,ID))
if ID=""
QUIT
Begin DoDot:1
+4 WRITE !,NA,!,?7,PR,?60,UN,?70,ID
IF $Y+4>IOSL
DO HEADNA
End DoDot:1
+5 QUIT
+6 ;
HEADNA if $Y
WRITE @IOF
WRITE !,?12,"VA PRODUCT LIST",?IOM-35," ",TD," PAGE ",PG,!,"VA PRODUCT NAME",!,?5,"VA PRINT NAME",?55,"VA DISP UNIT",?70,"ID#",!,LINE,!
SET PG=PG+1
QUIT
