- 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 Feb 18, 2025@23:20:01 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