- 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 Apr 23, 2025@19:16:48 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
