- LRCAPU ; IHS/DIR/FJE - LAB CAP UTILITIES ; [ 3/17/93 ]
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;**101,105**;Sep 27, 1994
- WKLDNAME(LRCC) ;Call with CAP code or IFN, returns WKLD proc name.
- ;Sets these vars:
- ; LRCAPNAM=WKLD proc name
- ; LRCAPFLG=Reportable flag
- ; LRCAPNUM=the WKLD code #
- ; LRCAPIFN=IFN of the WKLD entry
- ;The caller must kill these when done.
- ;Called by: LRCAPML/LRCAPR2/LRRP6A1/LRRP6B1,LRRP8C,LRCAPMA
- ;Called by:
- ;
- N LRNOD,LRNAM
- S LRNAM="*ERROR* CAN'T FIND WKLD CODE: "_LRCC
- S LRCAPFLG=-1,(LRCAPNAM,LRCAPNUM,LRCAPIFN)=""
- Q:'$L($G(LRCC)) LRNAM
- I LRCC?5N1"."4N.5N S LRCC=$O(^LAM("C",LRCC_" ",0)) Q:'LRCC LRNAM
- S LRNOD=$G(^LAM(LRCC,0)) Q:'$L(LRNOD) LRNAM
- S (LRCAPNAM,LRNAM)=$E($P(LRNOD,U),1,63),LRCAPNUM=$P(LRNOD,U,2)
- S LRCAPFLG=+$P(LRNOD,U,5),LRCAPIFN=LRCC
- S:LRCAPFLG (LRCAPNAM,LRNAM)="+"_LRCAPNAM
- Q LRNAM
- WKLDCLN ;Kill WKLD vars
- ;CALLED BY: LRCAPML/LRCAPR4/LRRP6,LRCAPMA,LRRP8
- K LRCAPIFN,LRCAPNAM,LRCAPNUM,LRCAPFLG
- Q
- DIS ;Display Accession workload called by LRCAPVM
- N DA,DIC,D0,DIE,DX,DR,IX,LRICS,X,LREND
- S DR=0,DA(1)=0,DA(2)=LRAN,DA(3)=LRAD,DA(4)=LRAA,LRICS="^LRO(68,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_",4," W @IOF
- S IX=0 F S IX=$O(LRTS(IX)) Q:IX<1!($G(LREND)) D
- . S DA(1)=IX,DIC=LRICS_DA(1)_",1," S X=$G(^LAB(60,DA(1),0)) I $L(X) W !,$P(X,U),! S DA=0 D
- . .F S DA=$O(@(DIC_DA_")")) Q:DA<1!($G(LREND)) D EN^DIQ I $E(IOST,1,2)="C-"&($Y>16) D PAUSE W:'$G(LREND) @IOF
- Q
- PRTINIT ;
- S (LRDSHS,LRSTRS)=""
- S $P(LRDSHS,"-",IOM)="-"
- S $P(LRSTRS,"*",IOM)="*"
- S LRPAG=0
- Q
- PRTCLN ;
- K LRHDR,LRHDR2,LRHDR3,LRCLHDR,LRCLHDR2,LRCLHDR3,LRDSHS,LRSTRS,LRPAG
- Q
- NPG ;New page
- D:$E(IOST,1,2)="C-" PAUSE
- Q:LREND
- W @IOF
- D HDR
- Q
- HDR ;Header for 80 col.
- S LRPAG=LRPAG+1
- W:$D(LRHDR)#2 !?((80-$L(LRHDR))/2),LRHDR,?72,"Page ",$J(LRPAG,3),!
- W:$D(LRHDR2)#2 ?((80-$L(LRHDR2))/2),LRHDR2,!
- W:$D(LRHDR3)#2 ?((80-$L(LRHDR3))/2),LRHDR3,!
- W:$D(LRCLHDR)#2 !,LRCLHDR,!
- W:$D(LRCLHDR2)#2 LRCLHDR2,!
- W:$D(LRCLHDR3)#2 LRCLHDR3,!
- W $E(LRDSHS,1,80),!
- Q
- PAUSE ;
- Q:$G(LREND)
- K DIR S DIR(0)="E" D ^DIR
- S:($D(DTOUT))!($D(DUOUT)) LREND=1
- Q
- LRCAPU ; IHS/DIR/FJE - LAB CAP UTILITIES ; [ 3/17/93 ]
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;**101,105**;Sep 27, 1994
- WKLDNAME(LRCC) ;Call with CAP code or IFN, returns WKLD proc name.
- +1 ;Sets these vars:
- +2 ; LRCAPNAM=WKLD proc name
- +3 ; LRCAPFLG=Reportable flag
- +4 ; LRCAPNUM=the WKLD code #
- +5 ; LRCAPIFN=IFN of the WKLD entry
- +6 ;The caller must kill these when done.
- +7 ;Called by: LRCAPML/LRCAPR2/LRRP6A1/LRRP6B1,LRRP8C,LRCAPMA
- +8 ;Called by:
- +9 ;
- +10 NEW LRNOD,LRNAM
- +11 SET LRNAM="*ERROR* CAN'T FIND WKLD CODE: "_LRCC
- +12 SET LRCAPFLG=-1
- SET (LRCAPNAM,LRCAPNUM,LRCAPIFN)=""
- +13 IF '$LENGTH($GET(LRCC))
- QUIT LRNAM
- +14 IF LRCC?5N1"."4N.5N
- SET LRCC=$ORDER(^LAM("C",LRCC_" ",0))
- IF 'LRCC
- QUIT LRNAM
- +15 SET LRNOD=$GET(^LAM(LRCC,0))
- IF '$LENGTH(LRNOD)
- QUIT LRNAM
- +16 SET (LRCAPNAM,LRNAM)=$EXTRACT($PIECE(LRNOD,U),1,63)
- SET LRCAPNUM=$PIECE(LRNOD,U,2)
- +17 SET LRCAPFLG=+$PIECE(LRNOD,U,5)
- SET LRCAPIFN=LRCC
- +18 IF LRCAPFLG
- SET (LRCAPNAM,LRNAM)="+"_LRCAPNAM
- +19 QUIT LRNAM
- WKLDCLN ;Kill WKLD vars
- +1 ;CALLED BY: LRCAPML/LRCAPR4/LRRP6,LRCAPMA,LRRP8
- +2 KILL LRCAPIFN,LRCAPNAM,LRCAPNUM,LRCAPFLG
- +3 QUIT
- DIS ;Display Accession workload called by LRCAPVM
- +1 NEW DA,DIC,D0,DIE,DX,DR,IX,LRICS,X,LREND
- +2 SET DR=0
- SET DA(1)=0
- SET DA(2)=LRAN
- SET DA(3)=LRAD
- SET DA(4)=LRAA
- SET LRICS="^LRO(68,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_",4,"
- WRITE @IOF
- +3 SET IX=0
- FOR
- SET IX=$ORDER(LRTS(IX))
- IF IX<1!($GET(LREND))
- QUIT
- Begin DoDot:1
- +4 SET DA(1)=IX
- SET DIC=LRICS_DA(1)_",1,"
- SET X=$GET(^LAB(60,DA(1),0))
- IF $LENGTH(X)
- WRITE !,$PIECE(X,U),!
- SET DA=0
- Begin DoDot:2
- +5 FOR
- SET DA=$ORDER(@(DIC_DA_")"))
- IF DA<1!($GET(LREND))
- QUIT
- DO EN^DIQ
- IF $EXTRACT(IOST,1,2)="C-"&($Y>16)
- DO PAUSE
- IF '$GET(LREND)
- WRITE @IOF
- End DoDot:2
- End DoDot:1
- +6 QUIT
- PRTINIT ;
- +1 SET (LRDSHS,LRSTRS)=""
- +2 SET $PIECE(LRDSHS,"-",IOM)="-"
- +3 SET $PIECE(LRSTRS,"*",IOM)="*"
- +4 SET LRPAG=0
- +5 QUIT
- PRTCLN ;
- +1 KILL LRHDR,LRHDR2,LRHDR3,LRCLHDR,LRCLHDR2,LRCLHDR3,LRDSHS,LRSTRS,LRPAG
- +2 QUIT
- NPG ;New page
- +1 IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE
- +2 IF LREND
- QUIT
- +3 WRITE @IOF
- +4 DO HDR
- +5 QUIT
- HDR ;Header for 80 col.
- +1 SET LRPAG=LRPAG+1
- +2 IF $DATA(LRHDR)#2
- WRITE !?((80-$LENGTH(LRHDR))/2),LRHDR,?72,"Page ",$JUSTIFY(LRPAG,3),!
- +3 IF $DATA(LRHDR2)#2
- WRITE ?((80-$LENGTH(LRHDR2))/2),LRHDR2,!
- +4 IF $DATA(LRHDR3)#2
- WRITE ?((80-$LENGTH(LRHDR3))/2),LRHDR3,!
- +5 IF $DATA(LRCLHDR)#2
- WRITE !,LRCLHDR,!
- +6 IF $DATA(LRCLHDR2)#2
- WRITE LRCLHDR2,!
- +7 IF $DATA(LRCLHDR3)#2
- WRITE LRCLHDR3,!
- +8 WRITE $EXTRACT(LRDSHS,1,80),!
- +9 QUIT
- PAUSE ;
- +1 IF $GET(LREND)
- QUIT
- +2 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +3 IF ($DATA(DTOUT))!($DATA(DUOUT))
- SET LREND=1
- +4 QUIT