SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ; 5/24/11 11:27am
;;5.3;scheduling;**263,280,288,397,491,554,638**;AUG 13 1993;Build 8
;
;SD/491 - identify clinic institution through DIVISION ---> INSTITUTION path
EN ;
;OPTION HEADER
;
D HD
;
;SELECT FILE TO EDIT
;
EN1 D SEL G END:X["^",END:X=""
;
;EDIT PARAMETER FILE
;
D EDIT G EN:'$D(Y)
G END
Q
;
SEL ;SELECT PARAMETER FILE
S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)=" 1. Wait List Service/Specialty (409.31)"
S DIR("L")=" 2. Wait List Clinic Location (409.32)"
D ^DIR S SDWLF=X
K DIR,DILN,DINDEX
Q
EDIT ;EDIT FILE PARAMETERS
I SDWLF=1 D SB1 Q:$D(DUOUT)
I SDWLF=2 D SB2 Q:$D(DUOUT)
Q
SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)"
D ^DIC
I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q
Q:Y<0 Q:$D(DUOUT) S SDWLDSS=+Y
I '$D(^SDWL(409.31,"B",SDWLDSS)) D
.S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN
S DA=$O(^SDWL(409.31,"B",SDWLDSS,""))
SB1A S DIR(0)="PAO^4:EMZ" D ^DIR
I X="" W *7," Required" G SB1A
I X["^" D:'$D(^SDWL(409.31,DA,"I")) S DUOUT=1 Q
.S DIK="^SDWL(409.31," D ^DIK
S X=$$GET1^DIQ(4,+Y_",",11)
I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A
I '$D(^SDWL(409.31,DA,"I","B",+Y)) D
.S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y
I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0))
K DIC,DIE,DIR,DR
W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D
.W *7,!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
.S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D
..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK
K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV
Q
SB2 N STR,INST,DIC,SDWLSC,SDWLSTOP S SDWLSTOP=0
W ! S DIC(0)="AEMNZ",DIC("A")="Select Clinic: ",DIC=44
S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2)"
S DIC("W")="S STR=$$CLIN^SDWLPE(+Y) I STR W ?50,""- "",$E($P(STR,U,3),1,25),""("",$P(STR,U,2),"")"""
D ^DIC I Y<1 K DIC,DA Q
Q:$D(DUOUT) S SDWLSC=+Y S INST=+STR ;$$CLIN(SDWLSC)
I $P(STR,U,6)'="" W !,*7,$P(STR,U,6) G SB2
N SDANEW S SDANEW=""
I '$D(^SDWL(409.32,"B",SDWLSC)) D
.S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN
.N DA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) S SDANEW=DA
.S DIE="^SDWL(409.32,",DR=".02////^S X=INST" D ^DIE
N DA,SDA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")),SDA=DA
S DR="1",DIE="^SDWL(409.32," D ^DIE
I SDANEW,'X D D ESB2 H 1 G SB2
.W *7,!!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
.S DA=SDANEW S DIK="^SDWL(409.32," D ^DIK
I '$P(^SDWL(409.32,SDA,0),U,3) I $P(^SDWL(409.32,SDA,0),U,2) S DR="2////^S X=DUZ" D ^DIE ;Checks to see whether the ACTIVATION DATE ENTERED BY field is filled before filling it SD*5.3*554
N DIC
S SDWLSCN=$P($G(^SDWL(409.32,SDA,0)),U,1) D Q:SDWLSTOP
.I $D(^SDWL(409.3,"SC",SDWLSCN))&'$P($G(^SDWL(409.32,SDA,0)),U,4) D ; Patch SD*5.3*638 adds a check for data in the DATE INACTIVATED (#3) field of the SD WL CLINIC LOCATION (409.32) file before evaluating open wait list entries.
..S SDWLN="",SDWLCNT=0 F S SDWLN=$O(^SDWL(409.3,"SC",SDWLSCN,SDWLN)) Q:SDWLN="" D
...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1
..I SDWLSTOP W !,"This Clinic has Patients on the Wait List and can not be inactivated." H 2 Q
N SDTEST S SDTEST="" I $G(SDWLN) S SDTEST=$$GET1^DIQ(409.32,SDWLN,3) ;Set Variable SDTEST equal to the information in the INACTIVATED DATE field
S DR="3",DIE="^SDWL(409.32," D ^DIE I $G(X)'=SDTEST D ; Populates the INACTIVATED DATE ENTERED BY field only if the INACTIVATED DATE field is filled - SD*5.3*554
.I X'="" S DR="4////^S X=+DUZ" D ^DIE
.E S DR="4////^S X=@" D ^DIE ;SD*5.3*554
ESB2 ;
K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF
Q
SWT ;SWITCH FOR INACTIVATION OF PARAMETER FILE
Q
HD ;HEADER
W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",!
W !,?80-$L("------------------------------")\2,"------------------------------",!
END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y
Q
CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
; function to return:
; 1 2 3 4 5 6 7
; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ INST Name _U_ DIV Pointer to ^DG(40.8 _U_N/L_U_Message_U_TYPE
; ( INST^STA NUM^SNAM^DIV^N/L^MESS^TYPE )
; N/L - N -National/L -Local
; TYPE - type of entry in file # 44 (field #2)
; C:CLINIC
; M:MODULE
; W:WARD
; Z:OTHER LOCATION
; N:NON-CLINIC STOP
; F:FILE AREA
; I:IMAGING
; OR:OPERATING ROOM
;
; with optional Message:
;
; if STA=""
; - INST^^SNAM^DIV^N/L^' - No Station Number on file' ^ TYPE
; or
; - 0^^^DIV^^' - No Institution has been identified '^ TYPE
; - 0^^^-1^^' - No Division has been identified' ^ TYPE
;
; if entry is inactivated:
;
; - INST^^SNAM^DIV^N/L^' - Inactive treating medical facility' ^ TYPE
; - -1^^^^^' - No clinic on file' ^
;
I +CL=0!'$D(^SC(+CL)) Q -1_"^^^^^ - No clinic on file^"
N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN=""
N TYPE S TYPE=$$GET1^DIQ(44,CL_",",2,"E")
S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
I DIV=0 S SDWMES=" - No Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES_U_TYPE
S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
I INS=0 S SDWMES=" - No Institution has been identified" Q 0_"^^^"_DIV_"^^"_SDWMES_U_TYPE
E S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name
I STN="" S SDWMES=" - No Station Number on file"
I '$$TF^XUAF4(INS) S SDWMES=SDWMES_" - Inactive treating medical facility"
S SNL=$$GET1^DIQ(4,INS_",",11,"I")
Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES_U_TYPE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLPE 6625 printed Dec 13, 2024@03:02:57 Page 2
SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ; 5/24/11 11:27am
+1 ;;5.3;scheduling;**263,280,288,397,491,554,638**;AUG 13 1993;Build 8
+2 ;
+3 ;SD/491 - identify clinic institution through DIVISION ---> INSTITUTION path
EN ;
+1 ;OPTION HEADER
+2 ;
+3 DO HD
+4 ;
+5 ;SELECT FILE TO EDIT
+6 ;
EN1 DO SEL
if X["^"
GOTO END
if X=""
GOTO END
+1 ;
+2 ;EDIT PARAMETER FILE
+3 ;
+4 DO EDIT
if '$DATA(Y)
GOTO EN
+5 GOTO END
+6 QUIT
+7 ;
SEL ;SELECT PARAMETER FILE
+1 SET DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location"
+2 SET DIR("L",1)="Select one of the following:"
+3 SET DIR("L",2)=""
+4 SET DIR("L",3)=" 1. Wait List Service/Specialty (409.31)"
+5 SET DIR("L")=" 2. Wait List Clinic Location (409.32)"
+6 DO ^DIR
SET SDWLF=X
+7 KILL DIR,DILN,DINDEX
+8 QUIT
EDIT ;EDIT FILE PARAMETERS
+1 IF SDWLF=1
DO SB1
if $DATA(DUOUT)
QUIT
+2 IF SDWLF=2
DO SB2
if $DATA(DUOUT)
QUIT
+3 QUIT
SB1 SET DIC(0)="AEQMZ"
SET DIC("A")="Select DSS ID: "
SET DIC="^DIC(40.7,"
SET DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)"
+1 DO ^DIC
+2 IF X["^"
IF $DATA(DA)
IF '$DATA(^SDWL(409.31,DA,"I"))
SET DIK="^SDWL(409.31,"
DO ^DIK
SET DUOUT=1
QUIT
+3 if Y<0
QUIT
if $DATA(DUOUT)
QUIT
SET SDWLDSS=+Y
+4 IF '$DATA(^SDWL(409.31,"B",SDWLDSS))
Begin DoDot:1
+5 SET DIC(0)="LX"
SET X=SDWLDSS
SET DIC="^SDWL(409.31,"
KILL DO
DO FILE^DICN
End DoDot:1
+6 SET DA=$ORDER(^SDWL(409.31,"B",SDWLDSS,""))
SB1A SET DIR(0)="PAO^4:EMZ"
DO ^DIR
+1 IF X=""
WRITE *7," Required"
GOTO SB1A
+2 IF X["^"
if '$DATA(^SDWL(409.31,DA,"I"))
Begin DoDot:1
+3 SET DIK="^SDWL(409.31,"
DO ^DIK
End DoDot:1
SET DUOUT=1
QUIT
+4 SET X=$$GET1^DIQ(4,+Y_",",11)
+5 IF X'["N"!'$$TF^XUAF4(+Y)
WRITE !,*7,"Invalid Entry. Must be 'National' Institution."
GOTO SB1A
+6 IF '$DATA(^SDWL(409.31,DA,"I","B",+Y))
Begin DoDot:1
+7 SET DA(1)=DA
SET DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_","
SET DIC("P")=409.311
SET X=+Y
KILL D0
DO FILE^DICN
IF +Y
SET DA=+Y
End DoDot:1
+8 IF $DATA(^SDWL(409.31,DA,"I","B",+Y))
SET DA(1)=DA
SET DA=$ORDER(^(+Y,0))
+9 KILL DIC,DIE,DIR,DR
+10 WRITE !
SET DR="1;3"
SET DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_","
DO ^DIE
+11 IF $PIECE(^SDWL(409.31,DA(1),"I",DA,0),U,2)=""
Begin DoDot:1
+12 WRITE *7,!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
+13 SET DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_","
DO ^DIK
IF '$PIECE(^SDWL(409.31,DA(1),"I",0),U,3)
Begin DoDot:2
+14 SET DIK="^SDWL(409.31,"
SET DA=DA(1)
DO ^DIK
End DoDot:2
End DoDot:1
+15 KILL DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV
+16 QUIT
SB2 NEW STR,INST,DIC,SDWLSC,SDWLSTOP
SET SDWLSTOP=0
+1 WRITE !
SET DIC(0)="AEMNZ"
SET DIC("A")="Select Clinic: "
SET DIC=44
+2 SET DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2)"
+3 SET DIC("W")="S STR=$$CLIN^SDWLPE(+Y) I STR W ?50,""- "",$E($P(STR,U,3),1,25),""("",$P(STR,U,2),"")"""
+4 DO ^DIC
IF Y<1
KILL DIC,DA
QUIT
+5 ;$$CLIN(SDWLSC)
if $DATA(DUOUT)
QUIT
SET SDWLSC=+Y
SET INST=+STR
+6 IF $PIECE(STR,U,6)'=""
WRITE !,*7,$PIECE(STR,U,6)
GOTO SB2
+7 NEW SDANEW
SET SDANEW=""
+8 IF '$DATA(^SDWL(409.32,"B",SDWLSC))
Begin DoDot:1
+9 SET DIC(0)="LX"
SET X=SDWLSC
SET DIC="^SDWL(409.32,"
DO FILE^DICN
+10 NEW DA
SET DA=$ORDER(^SDWL(409.32,"B",SDWLSC,""))
SET SDANEW=DA
+11 SET DIE="^SDWL(409.32,"
SET DR=".02////^S X=INST"
DO ^DIE
End DoDot:1
+12 NEW DA,SDA
SET DA=$ORDER(^SDWL(409.32,"B",SDWLSC,""))
SET SDA=DA
+13 SET DR="1"
SET DIE="^SDWL(409.32,"
DO ^DIE
+14 IF SDANEW
IF 'X
Begin DoDot:1
+15 WRITE *7,!!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
+16 SET DA=SDANEW
SET DIK="^SDWL(409.32,"
DO ^DIK
End DoDot:1
DO ESB2
HANG 1
GOTO SB2
+17 ;Checks to see whether the ACTIVATION DATE ENTERED BY field is filled before filling it SD*5.3*554
IF '$PIECE(^SDWL(409.32,SDA,0),U,3)
IF $PIECE(^SDWL(409.32,SDA,0),U,2)
SET DR="2////^S X=DUZ"
DO ^DIE
+18 NEW DIC
+19 SET SDWLSCN=$PIECE($GET(^SDWL(409.32,SDA,0)),U,1)
Begin DoDot:1
+20 ; Patch SD*5.3*638 adds a check for data in the DATE INACTIVATED (#3) field of the SD WL CLINIC LOCATION (409.32) file before evaluating open wait list entries.
IF $DATA(^SDWL(409.3,"SC",SDWLSCN))&'$PIECE($GET(^SDWL(409.32,SDA,0)),U,4)
Begin DoDot:2
+21 SET SDWLN=""
SET SDWLCNT=0
FOR
SET SDWLN=$ORDER(^SDWL(409.3,"SC",SDWLSCN,SDWLN))
if SDWLN=""
QUIT
Begin DoDot:3
+22 SET X=$GET(^SDWL(409.3,SDWLN,0))
IF '$DATA(^SDWL(409.3,SDWLN,"DIS"))
SET SDWLCNT=SDWLCNT+1
SET ^TMP("SDWLPE",$JOB,"DIS",SDWLN,SDWLCNT)=X
SET SDWLSTOP=1
End DoDot:3
+23 IF SDWLSTOP
WRITE !,"This Clinic has Patients on the Wait List and can not be inactivated."
HANG 2
QUIT
End DoDot:2
End DoDot:1
if SDWLSTOP
QUIT
+24 ;Set Variable SDTEST equal to the information in the INACTIVATED DATE field
NEW SDTEST
SET SDTEST=""
IF $GET(SDWLN)
SET SDTEST=$$GET1^DIQ(409.32,SDWLN,3)
+25 ; Populates the INACTIVATED DATE ENTERED BY field only if the INACTIVATED DATE field is filled - SD*5.3*554
SET DR="3"
SET DIE="^SDWL(409.32,"
DO ^DIE
IF $GET(X)'=SDTEST
Begin DoDot:1
+26 IF X'=""
SET DR="4////^S X=+DUZ"
DO ^DIE
+27 ;SD*5.3*554
IF '$TEST
SET DR="4////^S X=@"
DO ^DIE
End DoDot:1
ESB2 ;
+1 KILL DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF
+2 QUIT
SWT ;SWITCH FOR INACTIVATION OF PARAMETER FILE
+1 QUIT
HD ;HEADER
+1 if $DATA(IOF)
WRITE @IOF
WRITE !!,?80-$LENGTH("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",!
+2 WRITE !,?80-$LENGTH("------------------------------")\2,"------------------------------",!
END KILL SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y
+1 QUIT
CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
+1 ; function to return:
+2 ; 1 2 3 4 5 6 7
+3 ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ INST Name _U_ DIV Pointer to ^DG(40.8 _U_N/L_U_Message_U_TYPE
+4 ; ( INST^STA NUM^SNAM^DIV^N/L^MESS^TYPE )
+5 ; N/L - N -National/L -Local
+6 ; TYPE - type of entry in file # 44 (field #2)
+7 ; C:CLINIC
+8 ; M:MODULE
+9 ; W:WARD
+10 ; Z:OTHER LOCATION
+11 ; N:NON-CLINIC STOP
+12 ; F:FILE AREA
+13 ; I:IMAGING
+14 ; OR:OPERATING ROOM
+15 ;
+16 ; with optional Message:
+17 ;
+18 ; if STA=""
+19 ; - INST^^SNAM^DIV^N/L^' - No Station Number on file' ^ TYPE
+20 ; or
+21 ; - 0^^^DIV^^' - No Institution has been identified '^ TYPE
+22 ; - 0^^^-1^^' - No Division has been identified' ^ TYPE
+23 ;
+24 ; if entry is inactivated:
+25 ;
+26 ; - INST^^SNAM^DIV^N/L^' - Inactive treating medical facility' ^ TYPE
+27 ; - -1^^^^^' - No clinic on file' ^
+28 ;
+29 IF +CL=0!'$DATA(^SC(+CL))
QUIT -1_"^^^^^ - No clinic on file^"
+30 NEW SDWMES,STN,DIV,INS,SNL,STR,SNAM
SET SDWMES=""
SET STN=""
+31 NEW TYPE
SET TYPE=$$GET1^DIQ(44,CL_",",2,"E")
+32 SET DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
+33 IF DIV=0
SET SDWMES=" - No Division has been identified"
QUIT 0_"^^^"_-1_"^^"_SDWMES_U_TYPE
+34 SET INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
+35 IF INS=0
SET SDWMES=" - No Institution has been identified"
QUIT 0_"^^^"_DIV_"^^"_SDWMES_U_TYPE
+36 ;station number and name
IF '$TEST
SET STR=$$NS^XUAF4(INS)
SET STN=$PIECE(STR,U,2)
SET SNAM=$PIECE(STR,U)
+37 IF STN=""
SET SDWMES=" - No Station Number on file"
+38 IF '$$TF^XUAF4(INS)
SET SDWMES=SDWMES_" - Inactive treating medical facility"
+39 SET SNL=$$GET1^DIQ(4,INS_",",11,"I")
+40 QUIT INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES_U_TYPE
