SDWLAHRC ;;IOFO BAY PINES/TEH - EWL REPORT - COMPILE;06/12/2002 ; 20 Aug 2002 2:10 PM
;;5.3;scheduling;**419**;AUG 13 1993;Build 16
;
;
;
;
;
;
;
;
;
;=====================================================================================
; NOTES
;=====================================================================================
;
;
;
;
;
Q
COM ;START OF COMPILE - GET FIRST SORT
N %H,DA
S (SDWL0,SDWL1,SDWL2,SDWL3,SDWL4)="" K SDWLST
F S SDWL0=$O(^XTMP("SDWLAHR",SDWLJOB,SDWL0)) Q:SDWL0<1 D
.F S SDWL1=$O(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1)) Q:SDWL1="" D
..S SDWLTY=""
..I SDWL1["DAT" S SDWLTY="DAT"
..I SDWL1["NUM" S SDWLTY="NUM"
..I SDWL1["FT" S SDWLTY="FT"
..I SDWL1["RS" S SDWLTY="RS"
..I SDWL1["PRT" S SDWLTY="PRT"
..I SDWL1["ANM" S SDWLTY="ANM"
..I SDWLTY="" S SDWLTY="ERR"
..F S SDWL2=$O(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2)) Q:SDWL2="" D
...F S SDWL3=$O(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3)) Q:SDWL3="" D
....S SDWLX=$G(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3))
....I SDWLTY["FT" S SDWL4="" F S SDWL4=$O(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3,SDWL4)) Q:SDWL4="" D
.....S SDWLX=$G(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3,SDWL4))
....S SDWLST(SDWL0,SDWL2,SDWLX,SDWL1)=""
D CHK
D PRT
K PG,S,SDWL0,SDWL1,SDWL2,SDWL3,SDWL4,SDWLA,SDWLBDT,SDWLEDT,SDWLIEN,SDWLIENS,SDWLJOB,SDWLMN,SDWLMX,SDWLNM,SDWLOK
K SDWLR,SDWLTY,X,Y
Q
CHK ;GET SORT LOGICAL
S SDWLIEN=0 F S SDWLIEN=$O(^SDWL(409.3,SDWLIEN)) Q:SDWLIEN<1 D D SET1
.S (SDWL0,SDWL1,SDWL2,SDWL3)=""
.F S SDWL0=$O(SDWLST(SDWL0)) Q:SDWL0<1 D
..S SDWLOK(SDWL0)=0
..F S SDWL1=$O(SDWLST(SDWL0,SDWL1)) Q:SDWL1="" D
...F S SDWL2=$O(SDWLST(SDWL0,SDWL1,SDWL2)) Q:SDWL2="" D
....F S SDWL3=$O(SDWLST(SDWL0,SDWL1,SDWL2,SDWL3)) Q:SDWL3="" D
.....S SDWLNM="ZZ",SDWLTY=$S(SDWL3["PRT":"PRT",SDWL3["DAT":"DAT",SDWL3["RS":"RS",SDWL3["FT":"FT",SDWL3["NUM":"NUM",SDWL3["ANM":"ANM",1:"") D CHK1
Q
CHK1 ;CHECK EWL PATIENT FILE
I $D(SDWLTY),SDWLTY="FT" D Q
.S SDWLIENS=SDWLIEN_",",X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I") D
..I X[SDWL2 S SDWLOK(SDWL0)=1
I $D(SDWLTY),SDWLTY="NUM" D Q
.S SDWLNM=$P(SDWL2,U),SDWLMX=$P(SDWL2,U,2),SDWLIENS=SDWLIEN_",",X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I") D
..I X'<SDWLMN&(X'>SDWLMX) S SDWLOK(SDWL0)=1
I $D(SDWLTY),SDWLTY="DAT" D Q
.S SDWLBDT=$P(SDWL2,U),SDWLEDT=$P(SDWL2,U,2),SDWLIENS=SDWLIEN_",",X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I") D
..I X'<SDWLBDT&(X'>SDWLEDT) S SDWLOK(SDWL0)=1
I $D(SDWLTY),SDWLTY="RS" D Q
.S SDWLIENS=SDWLIEN_",",X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I") I SDWL2=X S SDWLOK(SDWL0)=1
I $D(SDWLTY),SDWLTY="PRT" D Q
.S SDWLIENS=SDWLIEN_",",X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I") I SDWL2=X S SDWLOK(SDWL0)=1
I $D(SDWLTY),SDWLTY="ANM" D Q
.S SDWLIENS=SDWLIEN_",",X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I"),SDWLNM=$$GET1^DIQ(2,X_",","NAME","I") S SDWLOK(SDWL0)=1
Q
SET1 ;
S SDWLR=0,SDWLOK=1 F S SDWLR=$O(SDWLOK(SDWLR)) Q:SDWLR<1 D
.S S=SDWLOK(SDWLR) I 'S S SDWLOK=0
I SDWLOK S ^XTMP("SDWLAHR",SDWLJOB,"LIST",SDWLNM,SDWLIEN)="",SDWL4=SDWL4+1
Q
PRT S PG=0 D HD
S SDWLA=0,SDWLNM="" K SDWLSTOP
F S SDWLNM=$O(^XTMP("SDWLAHR",SDWLJOB,"LIST",SDWLNM)) G END:$$S^ZTLOAD Q:SDWLNM="" D I $D(SDWLSTOP),'SDWLSTOP G END
.F S SDWLA=$O(^XTMP("SDWLAHR",SDWLJOB,"LIST",SDWLNM,SDWLA)) G END:$$S^%ZTLOAD Q:SDWLA<1 D I $D(SDWLSTOP),'SDWLSTOP G END
..S DIC="^SDWL(409.3,",DA=SDWLA,DR=":" D EN^DIQ
..I $Y>(IOSL-5) D:IOST["C-"
...S DIR(0)="Y",DIR("A")="Do You Wish to Continue",DIR("B")="YES" D ^DIR D I Y D HD Q
...S SDWLSTOP=Y
Q
HD W:$D(IOF) @IOF
W !!,?80-$L("EWL CUSTOM AD HOC REPORT")\2,"EWL CUSTOM AD HOC REPORT",?65 S PG=PG+1 W "PAGE: ",PG,!
S %H=+$H D YX^%DTC W ?80-$L(Y)\2,Y,!!
Q
END ;
K DIR,DIC,DR,DIE,SDWLERR,SDWLF,SDWLX,SDLFD,SDWLCTX,SDWLDAT,SDWLPROM,SDWLINST,SDWLI,SDWLTAG,SDWLY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLAHRC 3933 printed Nov 22, 2024@18:12:02 Page 2
SDWLAHRC ;;IOFO BAY PINES/TEH - EWL REPORT - COMPILE;06/12/2002 ; 20 Aug 2002 2:10 PM
+1 ;;5.3;scheduling;**419**;AUG 13 1993;Build 16
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;
+7 ;
+8 ;
+9 ;
+10 ;
+11 ;=====================================================================================
+12 ; NOTES
+13 ;=====================================================================================
+14 ;
+15 ;
+16 ;
+17 ;
+18 ;
+19 QUIT
COM ;START OF COMPILE - GET FIRST SORT
+1 NEW %H,DA
+2 SET (SDWL0,SDWL1,SDWL2,SDWL3,SDWL4)=""
KILL SDWLST
+3 FOR
SET SDWL0=$ORDER(^XTMP("SDWLAHR",SDWLJOB,SDWL0))
if SDWL0<1
QUIT
Begin DoDot:1
+4 FOR
SET SDWL1=$ORDER(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1))
if SDWL1=""
QUIT
Begin DoDot:2
+5 SET SDWLTY=""
+6 IF SDWL1["DAT"
SET SDWLTY="DAT"
+7 IF SDWL1["NUM"
SET SDWLTY="NUM"
+8 IF SDWL1["FT"
SET SDWLTY="FT"
+9 IF SDWL1["RS"
SET SDWLTY="RS"
+10 IF SDWL1["PRT"
SET SDWLTY="PRT"
+11 IF SDWL1["ANM"
SET SDWLTY="ANM"
+12 IF SDWLTY=""
SET SDWLTY="ERR"
+13 FOR
SET SDWL2=$ORDER(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2))
if SDWL2=""
QUIT
Begin DoDot:3
+14 FOR
SET SDWL3=$ORDER(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3))
if SDWL3=""
QUIT
Begin DoDot:4
+15 SET SDWLX=$GET(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3))
+16 IF SDWLTY["FT"
SET SDWL4=""
FOR
SET SDWL4=$ORDER(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3,SDWL4))
if SDWL4=""
QUIT
Begin DoDot:5
+17 SET SDWLX=$GET(^XTMP("SDWLAHR",SDWLJOB,SDWL0,SDWL1,SDWL2,SDWL3,SDWL4))
End DoDot:5
+18 SET SDWLST(SDWL0,SDWL2,SDWLX,SDWL1)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 DO CHK
+20 DO PRT
+21 KILL PG,S,SDWL0,SDWL1,SDWL2,SDWL3,SDWL4,SDWLA,SDWLBDT,SDWLEDT,SDWLIEN,SDWLIENS,SDWLJOB,SDWLMN,SDWLMX,SDWLNM,SDWLOK
+22 KILL SDWLR,SDWLTY,X,Y
+23 QUIT
CHK ;GET SORT LOGICAL
+1 SET SDWLIEN=0
FOR
SET SDWLIEN=$ORDER(^SDWL(409.3,SDWLIEN))
if SDWLIEN<1
QUIT
Begin DoDot:1
+2 SET (SDWL0,SDWL1,SDWL2,SDWL3)=""
+3 FOR
SET SDWL0=$ORDER(SDWLST(SDWL0))
if SDWL0<1
QUIT
Begin DoDot:2
+4 SET SDWLOK(SDWL0)=0
+5 FOR
SET SDWL1=$ORDER(SDWLST(SDWL0,SDWL1))
if SDWL1=""
QUIT
Begin DoDot:3
+6 FOR
SET SDWL2=$ORDER(SDWLST(SDWL0,SDWL1,SDWL2))
if SDWL2=""
QUIT
Begin DoDot:4
+7 FOR
SET SDWL3=$ORDER(SDWLST(SDWL0,SDWL1,SDWL2,SDWL3))
if SDWL3=""
QUIT
Begin DoDot:5
+8 SET SDWLNM="ZZ"
SET SDWLTY=$SELECT(SDWL3["PRT":"PRT",SDWL3["DAT":"DAT",SDWL3["RS":"RS",SDWL3["FT":"FT",SDWL3["NUM":"NUM",SDWL3["ANM":"ANM",1:"")
DO CHK1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
DO SET1
+9 QUIT
CHK1 ;CHECK EWL PATIENT FILE
+1 IF $DATA(SDWLTY)
IF SDWLTY="FT"
Begin DoDot:1
+2 SET SDWLIENS=SDWLIEN_","
SET X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I")
Begin DoDot:2
+3 IF X[SDWL2
SET SDWLOK(SDWL0)=1
End DoDot:2
End DoDot:1
QUIT
+4 IF $DATA(SDWLTY)
IF SDWLTY="NUM"
Begin DoDot:1
+5 SET SDWLNM=$PIECE(SDWL2,U)
SET SDWLMX=$PIECE(SDWL2,U,2)
SET SDWLIENS=SDWLIEN_","
SET X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I")
Begin DoDot:2
+6 IF X'<SDWLMN&(X'>SDWLMX)
SET SDWLOK(SDWL0)=1
End DoDot:2
End DoDot:1
QUIT
+7 IF $DATA(SDWLTY)
IF SDWLTY="DAT"
Begin DoDot:1
+8 SET SDWLBDT=$PIECE(SDWL2,U)
SET SDWLEDT=$PIECE(SDWL2,U,2)
SET SDWLIENS=SDWLIEN_","
SET X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I")
Begin DoDot:2
+9 IF X'<SDWLBDT&(X'>SDWLEDT)
SET SDWLOK(SDWL0)=1
End DoDot:2
End DoDot:1
QUIT
+10 IF $DATA(SDWLTY)
IF SDWLTY="RS"
Begin DoDot:1
+11 SET SDWLIENS=SDWLIEN_","
SET X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I")
IF SDWL2=X
SET SDWLOK(SDWL0)=1
End DoDot:1
QUIT
+12 IF $DATA(SDWLTY)
IF SDWLTY="PRT"
Begin DoDot:1
+13 SET SDWLIENS=SDWLIEN_","
SET X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I")
IF SDWL2=X
SET SDWLOK(SDWL0)=1
End DoDot:1
QUIT
+14 IF $DATA(SDWLTY)
IF SDWLTY="ANM"
Begin DoDot:1
+15 SET SDWLIENS=SDWLIEN_","
SET X=$$GET1^DIQ(409.3,SDWLIENS,SDWL1,"I")
SET SDWLNM=$$GET1^DIQ(2,X_",","NAME","I")
SET SDWLOK(SDWL0)=1
End DoDot:1
QUIT
+16 QUIT
SET1 ;
+1 SET SDWLR=0
SET SDWLOK=1
FOR
SET SDWLR=$ORDER(SDWLOK(SDWLR))
if SDWLR<1
QUIT
Begin DoDot:1
+2 SET S=SDWLOK(SDWLR)
IF 'S
SET SDWLOK=0
End DoDot:1
+3 IF SDWLOK
SET ^XTMP("SDWLAHR",SDWLJOB,"LIST",SDWLNM,SDWLIEN)=""
SET SDWL4=SDWL4+1
+4 QUIT
PRT SET PG=0
DO HD
+1 SET SDWLA=0
SET SDWLNM=""
KILL SDWLSTOP
+2 FOR
SET SDWLNM=$ORDER(^XTMP("SDWLAHR",SDWLJOB,"LIST",SDWLNM))
if $$S^ZTLOAD
GOTO END
if SDWLNM=""
QUIT
Begin DoDot:1
+3 FOR
SET SDWLA=$ORDER(^XTMP("SDWLAHR",SDWLJOB,"LIST",SDWLNM,SDWLA))
if $$S^%ZTLOAD
GOTO END
if SDWLA<1
QUIT
Begin DoDot:2
+4 SET DIC="^SDWL(409.3,"
SET DA=SDWLA
SET DR=":"
DO EN^DIQ
+5 IF $Y>(IOSL-5)
if IOST["C-"
Begin DoDot:3
+6 SET DIR(0)="Y"
SET DIR("A")="Do You Wish to Continue"
SET DIR("B")="YES"
DO ^DIR
Begin DoDot:4
End DoDot:4
IF Y
DO HD
QUIT
+7 SET SDWLSTOP=Y
End DoDot:3
End DoDot:2
IF $DATA(SDWLSTOP)
IF 'SDWLSTOP
GOTO END
End DoDot:1
IF $DATA(SDWLSTOP)
IF 'SDWLSTOP
GOTO END
+8 QUIT
HD if $DATA(IOF)
WRITE @IOF
+1 WRITE !!,?80-$LENGTH("EWL CUSTOM AD HOC REPORT")\2,"EWL CUSTOM AD HOC REPORT",?65
SET PG=PG+1
WRITE "PAGE: ",PG,!
+2 SET %H=+$HOROLOG
DO YX^%DTC
WRITE ?80-$LENGTH(Y)\2,Y,!!
+3 QUIT
END ;
+1 KILL DIR,DIC,DR,DIE,SDWLERR,SDWLF,SDWLX,SDLFD,SDWLCTX,SDWLDAT,SDWLPROM,SDWLINST,SDWLI,SDWLTAG,SDWLY
+2 QUIT
