- ECXLAB1 ;ALB/JAP,BIR/CML,-Driver Routine for DSS Lab Extract; [ 03/20/97 11:54 AM ] ; 8/8/01 4:16pm
- ;;3.0;DSS EXTRACTS;**8,37**;Dec 22, 1997
- EN ;entry point from option
- N JJ,SS,LN,X,Y,DIRUT,DTOUT,DUOUT,DIR
- I '$O(^ECX(728,0)) D Q
- .W $C(7),!!,"You have not yet defined your facility in the DSS EXTRACTS file (#728)!"
- .I ($E(IOST)="C") D
- ..S SS=22-$Y F JJ=1:1:SS W !
- ..K X,Y
- ..S DIR(0)="E" W ! D ^DIR K DIR
- ;Check for lmip flag (field .5) in file (#728), if empty string write message and terminate extract
- I $G(^ECX(728,1,"LMIP"))'=1 D Q
- .S $P(LN,"-",80)=""
- .W !,"LAB Extracts cannot be generated without LMIP Codes.",!,"Please check with your LAB ADPAC or LAB Service."
- .W !,"...exiting."
- D BEG^ECXLABN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXLAB1 739 printed Feb 18, 2025@23:19:11 Page 2
- ECXLAB1 ;ALB/JAP,BIR/CML,-Driver Routine for DSS Lab Extract; [ 03/20/97 11:54 AM ] ; 8/8/01 4:16pm
- +1 ;;3.0;DSS EXTRACTS;**8,37**;Dec 22, 1997
- EN ;entry point from option
- +1 NEW JJ,SS,LN,X,Y,DIRUT,DTOUT,DUOUT,DIR
- +2 IF '$ORDER(^ECX(728,0))
- Begin DoDot:1
- +3 WRITE $CHAR(7),!!,"You have not yet defined your facility in the DSS EXTRACTS file (#728)!"
- +4 IF ($EXTRACT(IOST)="C")
- Begin DoDot:2
- +5 SET SS=22-$Y
- FOR JJ=1:1:SS
- WRITE !
- +6 KILL X,Y
- +7 SET DIR(0)="E"
- WRITE !
- DO ^DIR
- KILL DIR
- End DoDot:2
- End DoDot:1
- QUIT
- +8 ;Check for lmip flag (field .5) in file (#728), if empty string write message and terminate extract
- +9 IF $GET(^ECX(728,1,"LMIP"))'=1
- Begin DoDot:1
- +10 SET $PIECE(LN,"-",80)=""
- +11 WRITE !,"LAB Extracts cannot be generated without LMIP Codes.",!,"Please check with your LAB ADPAC or LAB Service."
- +12 WRITE !,"...exiting."
- End DoDot:1
- QUIT
- +13 DO BEG^ECXLABN
- +14 QUIT