LRAPKOEU ;DSS/FHS - AP CPRS DIALOG UTILITIES ROUTINE ; 3/4/16 4:02pm
;;5.2;LAB SERVICE;**462**;Sep 27, 1994;Build 44
Q
;
PRT ; Entry point for print File #60 AP CPRS entries.
N I,J,X,Y,DA,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,DR,AV1,AV2,AV3,J,VAL,LRPAG,LRY
N LREND,LRTST,LRSPEC,LRSCR,LRX,LINE,%ZIS,POP,I
N ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
W @(IOF)
I '$O(^LAB(60,"AV1",0)) D Q
. W !,"There are no AP CPRS definitions in the file"
S DIR(0)="SO^1:Laboratory Test (#60);2:CPRS AP Screen (#67.91)"
S DIR("A")="Sort Report by "
S DIR("?")="How do you want the report to be sorted"
D ^DIR
S LRY=Y_","_Y(0) ;W !,Y," ",Y(0),LREND=0
S %ZIS="QN",%ZIS("A")="Print on what Device ",%ZIS("B")="HOME"
D ^%ZIS K %ZIS G:$G(POP) PRTEND
I IO'=IO(0)!($D(IO("Q"))) D G PRTEND
. S ZTRTN="PRTTSK^LRAPKOEU",ZTIO="ION",ZTDESC="PRINT CPRS AP DIALOG LISTING "_Y(0)
. S ZTSAVE("LRY*")="" D ^%ZTLOAD,^%ZISC
. W !,$S($G(ZTSK):"Task # "_ZTSK,11:"Task Error")
PRTTSK ;Entry point for TASK Printing
S VAL="^LAB(60,""AV1"")",LRPAG=0,LINE=0
F S VAL=$Q(@VAL) Q:$QS(VAL,2)'="AV1" D
. I +LRY=1 S AV1($P(^LAB(60,$QS(VAL,3),0),U)_"["_$QS(VAL,3)_"]",$P(^LAB(69.71,$QS(VAL,4),0),U))=""
. I +LRY=2 S AV2($P(^LAB(69.71,$QS(VAL,4),0),U),$P(^LAB(60,$QS(VAL,3),0),U)_"["_$QS(VAL,3)_"]")=""
PO ;Print out put
S LINE=1 I +LRY=1 D HDR1 D ;Lab Test, CPRS Screen
. S LRTST="" F S LRTST=$O(AV1(LRTST)) Q:LRTST=""!($G(LREND)) D
. . W !!,"TEST NAME: ",LRTST
. . S LRSCR="" F S LRSCR=$O(AV1(LRTST,LRSCR)) Q:LRSCR=""!($G(LREND)) D
. . . W !?5,"CPRS SCREEN: ",LRSCR D EPAGE Q:$G(LREND)
I +LRY=2 D HDR1 D ;CPRS Screen,Lab Test
. S LRSCR="" F S LRSCR=$O(AV2(LRSCR)) Q:LRSCR=""!($G(LREND)) D
. . W !!,"CPRS Sreen Name: ",LRSCR Q:$G(LREND)
. . S LRTST="" F S LRTST=$O(AV2(LRSCR,LRTST)) Q:LRTST=""!($G(LREND)) D
. . . W !?5,"Laboratory Test: ",LRTST D EPAGE Q:$G(LREND)
W !,$$CJ^XLFSTR("=================== END OF REPORT ===================",IOM)
PRTEND ;
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HDR1 ;
;W @IOF
S LRPAG=$G(LRPAG)+1,LINE=3 W !!,$$CJ^XLFSTR("REPORT SORTED BY: "_$P(LRY,",",2)_" PAGE: "_LRPAG,IOM),!,?10,"[#IEN]" Q
;
EPAGE ;Line counter
S LINE=$G(LINE)+3 Q:LINE<(IOSL-3)
K DIR,DTOUT,DUOUT,DIRUT,Y
S LINE=2 W !
I $E(IOST,1)="C" S DIR(0)="E" D ^DIR K DIR I $G(Y)=0 S LREND=1 Q
D HDR1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPKOEU 2350 printed Dec 13, 2024@02:07:35 Page 2
LRAPKOEU ;DSS/FHS - AP CPRS DIALOG UTILITIES ROUTINE ; 3/4/16 4:02pm
+1 ;;5.2;LAB SERVICE;**462**;Sep 27, 1994;Build 44
+2 QUIT
+3 ;
PRT ; Entry point for print File #60 AP CPRS entries.
+1 NEW I,J,X,Y,DA,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,DR,AV1,AV2,AV3,J,VAL,LRPAG,LRY
+2 NEW LREND,LRTST,LRSPEC,LRSCR,LRX,LINE,%ZIS,POP,I
+3 NEW ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
+4 WRITE @(IOF)
+5 IF '$ORDER(^LAB(60,"AV1",0))
Begin DoDot:1
+6 WRITE !,"There are no AP CPRS definitions in the file"
End DoDot:1
QUIT
+7 SET DIR(0)="SO^1:Laboratory Test (#60);2:CPRS AP Screen (#67.91)"
+8 SET DIR("A")="Sort Report by "
+9 SET DIR("?")="How do you want the report to be sorted"
+10 DO ^DIR
+11 ;W !,Y," ",Y(0),LREND=0
SET LRY=Y_","_Y(0)
+12 SET %ZIS="QN"
SET %ZIS("A")="Print on what Device "
SET %ZIS("B")="HOME"
+13 DO ^%ZIS
KILL %ZIS
if $GET(POP)
GOTO PRTEND
+14 IF IO'=IO(0)!($DATA(IO("Q")))
Begin DoDot:1
+15 SET ZTRTN="PRTTSK^LRAPKOEU"
SET ZTIO="ION"
SET ZTDESC="PRINT CPRS AP DIALOG LISTING "_Y(0)
+16 SET ZTSAVE("LRY*")=""
DO ^%ZTLOAD
DO ^%ZISC
+17 WRITE !,$SELECT($GET(ZTSK):"Task # "_ZTSK,11:"Task Error")
End DoDot:1
GOTO PRTEND
PRTTSK ;Entry point for TASK Printing
+1 SET VAL="^LAB(60,""AV1"")"
SET LRPAG=0
SET LINE=0
+2 FOR
SET VAL=$QUERY(@VAL)
if $QSUBSCRIPT(VAL,2)'="AV1"
QUIT
Begin DoDot:1
+3 IF +LRY=1
SET AV1($PIECE(^LAB(60,$QSUBSCRIPT(VAL,3),0),U)_"["_$QSUBSCRIPT(VAL,3)_"]",$PIECE(^LAB(69.71,$QSUBSCRIPT(VAL,4),0),U))=""
+4 IF +LRY=2
SET AV2($PIECE(^LAB(69.71,$QSUBSCRIPT(VAL,4),0),U),$PIECE(^LAB(60,$QSUBSCRIPT(VAL,3),0),U)_"["_$QSUBSCRIPT(VAL,3)_"]")=""
End DoDot:1
PO ;Print out put
+1 ;Lab Test, CPRS Screen
SET LINE=1
IF +LRY=1
DO HDR1
Begin DoDot:1
+2 SET LRTST=""
FOR
SET LRTST=$ORDER(AV1(LRTST))
if LRTST=""!($GET(LREND))
QUIT
Begin DoDot:2
+3 WRITE !!,"TEST NAME: ",LRTST
+4 SET LRSCR=""
FOR
SET LRSCR=$ORDER(AV1(LRTST,LRSCR))
if LRSCR=""!($GET(LREND))
QUIT
Begin DoDot:3
+5 WRITE !?5,"CPRS SCREEN: ",LRSCR
DO EPAGE
if $GET(LREND)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+6 ;CPRS Screen,Lab Test
IF +LRY=2
DO HDR1
Begin DoDot:1
+7 SET LRSCR=""
FOR
SET LRSCR=$ORDER(AV2(LRSCR))
if LRSCR=""!($GET(LREND))
QUIT
Begin DoDot:2
+8 WRITE !!,"CPRS Sreen Name: ",LRSCR
if $GET(LREND)
QUIT
+9 SET LRTST=""
FOR
SET LRTST=$ORDER(AV2(LRSCR,LRTST))
if LRTST=""!($GET(LREND))
QUIT
Begin DoDot:3
+10 WRITE !?5,"Laboratory Test: ",LRTST
DO EPAGE
if $GET(LREND)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 WRITE !,$$CJ^XLFSTR("=================== END OF REPORT ===================",IOM)
PRTEND ;
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
HDR1 ;
+1 ;W @IOF
+2 SET LRPAG=$GET(LRPAG)+1
SET LINE=3
WRITE !!,$$CJ^XLFSTR("REPORT SORTED BY: "_$PIECE(LRY,",",2)_" PAGE: "_LRPAG,IOM),!,?10,"[#IEN]"
QUIT
+3 ;
EPAGE ;Line counter
+1 SET LINE=$GET(LINE)+3
if LINE<(IOSL-3)
QUIT
+2 KILL DIR,DTOUT,DUOUT,DIRUT,Y
+3 SET LINE=2
WRITE !
+4 IF $EXTRACT(IOST,1)="C"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $GET(Y)=0
SET LREND=1
QUIT
+5 DO HDR1
+6 QUIT
