ECXPROUI ;ALB/DAN - Display unit of issue records from file 420.5 ;3/6/17 15:25
;;3.0;DSS EXTRACTS;**166**;Dec 22, 1997;Build 24
;
N ECXPORT,ZTSAVE
W !!,"This report will list all units of issue that can be used in prosthetics.",!,"The list will include the 2 character name as well as the full name.",!
S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1
I $G(ECXPORT) D Q ;If exporting get records and display to screen
.K ^TMP($J,"ECXPROUI"),^TMP($J,"ECXPORT")
.D GETUNITS
.M ^TMP($J,"ECXPORT")=^TMP($J,"ECXPROUI")
.S ^TMP($J,"ECXPORT",0)="NAME^FULL NAME"
.D EXPDISP^ECXUTL1
.K ^TMP($J,"ECXPROUI"),^TMP($J,"ECXPORT")
.Q
;
D EN^XUTMDEVQ("START^ECXPROUI","Print unit of issue entries from file 420.5",.ZTSAVE)
Q
;
START ;
K ^TMP($J,"ECXPROUI")
D GETUNITS
D PRINT
K ^TMP($J,"ECXPROUI")
Q
;
GETUNITS ;Get unit of issue
N CNT,NAME,IEN,NODE
S CNT=0
S NAME="" F S NAME=$O(^PRCD(420.5,"B",NAME)) Q:NAME="" S IEN=0 F S IEN=$O(^PRCD(420.5,"B",NAME,IEN)) Q:'+IEN D
.Q:$L(NAME)'=2 ;Stop if name isn't in correct form
.S NODE=$G(^PRCD(420.5,IEN,0)) Q:NODE="" ;if node doesn't exist, problem with "B" cross reference
.S CNT=CNT+1,^TMP($J,"ECXPROUI",CNT)=NAME_"^"_$P(NODE,U,2)
.Q
Q
;
PRINT ;Display results
N NUM,DATA,PAGE,RDAT,QFLG
S (PAGE,QFLG)=0,RDAT=$$FMTE^XLFDT($E($$NOW^XLFDT,1,12))
D HEAD
S NUM=0 F S NUM=$O(^TMP($J,"ECXPROUI",NUM)) Q:'+NUM!(QFLG) D
.I $Y>($G(IOSL)-4) D HEAD Q:QFLG
.S DATA=^TMP($J,"ECXPROUI",NUM)
.W !,$P(DATA,"^"),?5,$P(DATA,"^",2)
.Q
Q
;
HEAD ;Print header
N Y,DIR
I $E(IOST)="C",PAGE>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
W @IOF
S PAGE=PAGE+1
W "Unit of Issue List on ",RDAT,?70,"Page: ",PAGE,!
W !,"NAME",?5,"FULL NAME",!,$$REPEAT^XLFSTR("-",80)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPROUI 1777 printed Dec 13, 2024@01:53:37 Page 2
ECXPROUI ;ALB/DAN - Display unit of issue records from file 420.5 ;3/6/17 15:25
+1 ;;3.0;DSS EXTRACTS;**166**;Dec 22, 1997;Build 24
+2 ;
+3 NEW ECXPORT,ZTSAVE
+4 WRITE !!,"This report will list all units of issue that can be used in prosthetics.",!,"The list will include the 2 character name as well as the full name.",!
+5 SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
+6 ;If exporting get records and display to screen
IF $GET(ECXPORT)
Begin DoDot:1
+7 KILL ^TMP($JOB,"ECXPROUI"),^TMP($JOB,"ECXPORT")
+8 DO GETUNITS
+9 MERGE ^TMP($JOB,"ECXPORT")=^TMP($JOB,"ECXPROUI")
+10 SET ^TMP($JOB,"ECXPORT",0)="NAME^FULL NAME"
+11 DO EXPDISP^ECXUTL1
+12 KILL ^TMP($JOB,"ECXPROUI"),^TMP($JOB,"ECXPORT")
+13 QUIT
End DoDot:1
QUIT
+14 ;
+15 DO EN^XUTMDEVQ("START^ECXPROUI","Print unit of issue entries from file 420.5",.ZTSAVE)
+16 QUIT
+17 ;
START ;
+1 KILL ^TMP($JOB,"ECXPROUI")
+2 DO GETUNITS
+3 DO PRINT
+4 KILL ^TMP($JOB,"ECXPROUI")
+5 QUIT
+6 ;
GETUNITS ;Get unit of issue
+1 NEW CNT,NAME,IEN,NODE
+2 SET CNT=0
+3 SET NAME=""
FOR
SET NAME=$ORDER(^PRCD(420.5,"B",NAME))
if NAME=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(^PRCD(420.5,"B",NAME,IEN))
if '+IEN
QUIT
Begin DoDot:1
+4 ;Stop if name isn't in correct form
if $LENGTH(NAME)'=2
QUIT
+5 ;if node doesn't exist, problem with "B" cross reference
SET NODE=$GET(^PRCD(420.5,IEN,0))
if NODE=""
QUIT
+6 SET CNT=CNT+1
SET ^TMP($JOB,"ECXPROUI",CNT)=NAME_"^"_$PIECE(NODE,U,2)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
PRINT ;Display results
+1 NEW NUM,DATA,PAGE,RDAT,QFLG
+2 SET (PAGE,QFLG)=0
SET RDAT=$$FMTE^XLFDT($EXTRACT($$NOW^XLFDT,1,12))
+3 DO HEAD
+4 SET NUM=0
FOR
SET NUM=$ORDER(^TMP($JOB,"ECXPROUI",NUM))
if '+NUM!(QFLG)
QUIT
Begin DoDot:1
+5 IF $Y>($GET(IOSL)-4)
DO HEAD
if QFLG
QUIT
+6 SET DATA=^TMP($JOB,"ECXPROUI",NUM)
+7 WRITE !,$PIECE(DATA,"^"),?5,$PIECE(DATA,"^",2)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
HEAD ;Print header
+1 NEW Y,DIR
+2 IF $EXTRACT(IOST)="C"
IF PAGE>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+3 WRITE @IOF
+4 SET PAGE=PAGE+1
+5 WRITE "Unit of Issue List on ",RDAT,?70,"Page: ",PAGE,!
+6 WRITE !,"NAME",?5,"FULL NAME",!,$$REPEAT^XLFSTR("-",80)
+7 QUIT
