- 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 Feb 19, 2025@00:29:27 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
