- SDWLBACC ;;IOFO BAY PINES/OG - BATCH CHANGE EWL CLINIC ; Compiled August 14, 2007 11:20:57
- ;;5.3;scheduling;**446**;AUG 13 1993;Build 77
- ;
- ; ******************************************************************
- ; CHANGE LOG
- ;
- ; DATE PATCH DESCRIPTION
- ; ---- ----- -----------
- ;
- ;
- N SDWLERR,SDWLOPT,SDWLSCL,SDWLHD,SDWLIN1,SDWLIN2,SDWLCL0,SDWLCL1,SDWLCL2,SDWLCSC1,SDWLCSC2,SDWLCM
- S SDWLHD="Scheduling/PCMM Batch Change EWL Clinic"
- W:$D(IOF) @IOF W !?80-$L(SDWLHD)\2,SDWLHD,!
- S SDWLERR=0,SDWLOPT=1,(SDWLIN2,SDWLCL1,SDWLCL2,SDWLCM)="",SDWLIN1=+$$SITE^VASITE()
- F D @("P"_SDWLOPT) Q:'SDWLOPT
- Q
- P1 ; Source Institution
- S DIR(0)="PAO^DIC(4,:EMNZ"
- S DIR("A")="Select Source Institution: "
- I SDWLIN1'="" S DIR("B")=$$GET1^DIQ(4,SDWLIN1,.01)
- S DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
- D ^DIR
- I Y<1 S SDWLOPT=0 Q
- S (SDWLIN1,SDWLIN2)=+Y,SDWLOPT=SDWLOPT+1
- Q
- P2 ; Source Clinic
- N DIR,SDWLSC
- S DIR(0)="PAO^SDWL(409.32,:EMNZ"
- S DIR("A")="Select Source Clinic: "
- I SDWLCL1'="" S DIR("B")=$$GET1^DIQ(409.32,SDWLCL1,.01)
- S DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN1"
- D ^DIR
- I Y="^" S SDWLOPT=0 Q
- I Y<1 S SDWLOPT=SDWLOPT-1 Q
- S SDWLCL0=+Y ; Wait list specific clinic
- S SDWLCL1=$P(Y,U,2) ; pointer to HOSPITAL LOCATION file
- S SDWLCSC1=$$GET1^DIQ(44,SDWLCL1,8,"I")_U_$$GET1^DIQ(44,SDWLCL1,8) ; Clinic stop code
- S SDWLOPT=SDWLOPT+1
- Q
- P3 ; Destination Institution
- S DIR(0)="PAO^DIC(4,:EMNZ"
- S DIR("A")="Select Destination Institution: "
- I SDWLIN1'="" S DIR("B")=$$GET1^DIQ(4,SDWLIN2,.01)
- S DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
- D ^DIR
- I Y="^" S SDWLOPT=0 Q
- I Y<1 S SDWLOPT=SDWLOPT-1 Q
- S SDWLIN2=+Y,SDWLOPT=SDWLOPT+1
- Q
- P4 ; Destination Clinic
- N DIR,SDWLSC,SDWLY
- S DIR(0)="PAO^SDWL(409.32,:EMNZ"
- S DIR("A")="Select Destination Clinic: "
- I SDWLCL2'="" S DIR("B")=$$GET1^DIQ(409.32,SDWLCL2,.01)
- S DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN2,+Y'=SDWLCL0"
- D ^DIR
- I Y="^" S SDWLOPT=0 Q
- I Y<1 S SDWLOPT=SDWLOPT-1 Q
- S SDWLY=+Y,SDWLSC=$P(Y,U,2) ; pointer to HOSPITAL LOCATION file
- ; get clinic's stop code. warn if different.
- S SDWLCSC2=$$GET1^DIQ(44,SDWLSC,8,"I")_U_$$GET1^DIQ(44,SDWLSC,8) ; Clinic's stop code
- I +SDWLCSC1'=+SDWLCSC2 D Q:'Y
- .S DIR(0)="Y"
- .S DIR("A")="The clinics' stop codes are different, continue"
- .S DIR("A",1)=$$GET1^DIQ(409.32,SDWLCL1,.01)_": "_$P(SDWLCSC1,U,2)_" ("_+SDWLCSC1_")"
- .S DIR("A",2)=$$GET1^DIQ(409.32,+Y,.01)_": "_$P(SDWLCSC2,U,2)_" ("_+SDWLCSC2_")"
- .S DIR("B")="YES"
- .D ^DIR
- .S:Y="^" SDWLOPT=0
- .Q
- S SDWLSCL=SDWLY,SDWLOPT=SDWLOPT+1
- Q
- P5 ; Comment
- D P4^SDWLE6
- Q
- P6 ; Confirmation and processing
- N DIR,Y
- S DIR(0)="Y"
- S DIR("A")="Proceed with batch clinic change"
- S DIR("B")="YES"
- D ^DIR
- D:Y CHNGCL
- S SDWLOPT=0
- Q
- CHNGCL ;
- N DIR,SDWLDA,SDWLCNT
- S SDWLDA="",SDWLCNT=0
- F S SDWLDA=$O(^SDWL(409.3,"SC",SDWLCL1,SDWLDA)) Q:'SDWLDA D
- .N DA,DIE,DIR,DR,SDWLDFN,SDWLIN,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLCL1,SDWLDDT,SDWLEEST,Y
- .D GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;23;27","I","SDWLTMP")
- .Q:SDWLTMP(409.3,SDWLDA_",",23,"I")="C" ; Only open entries.
- .S SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
- .S SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
- .S SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
- .S SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
- .S SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
- .S SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
- .Q:'$$UPDATE^SDWLE7(SDWLDFN,SDWLORDT,SDWLIN2,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA)
- .; disposition old entry
- .S DIE="^SDWL(409.3,",DA=SDWLDA,DR="19////^S X=DT;20////^S X=DUZ;21////^S X=""CL"";23////^S X=""C"""
- .D ^DIE
- .S SDWLCNT=SDWLCNT+1
- .Q
- W ! W:SDWLCNT "Clinics changed. " W SDWLCNT," entries processed."
- S DIR(0)="E" D ^DIR
- Q
- CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
- ; function to return:
- ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ Inst Name _U_ Div Pointer to ^DG(40.8 _U_N/L_U_Message
- ; ( INST^STA NUM^SNAM^DIV^N/L^MESS )
- ; N/L - N -National/L -Local
- ; with Message:
- ; - if STA="" INST^^SNAM^DIV^^N/L^' - No Station Number on file'
- ; or
- ; - 0^^^DIV^^' - No Institution has been identified'
- ; - 0^^^-1^^' - no Division has been identified'
- ; - -1 no clinic on file'
- I '$D(^SC(+CL)) Q -1_"^^^^^no clinic on file"
- N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN=""
- S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
- I DIV=0 S SDWMES="no Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES
- S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
- I INS=0 S SDWMES="No Institution has been identified" Q 0_"^^^"_DIV_"^"_SDWMES
- 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="Inactive treating medical facility"
- S SNL=$$GET1^DIQ(4,INS_",",11,"I")
- Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLBACC 5169 printed Jan 18, 2025@04:03:24 Page 2
- SDWLBACC ;;IOFO BAY PINES/OG - BATCH CHANGE EWL CLINIC ; Compiled August 14, 2007 11:20:57
- +1 ;;5.3;scheduling;**446**;AUG 13 1993;Build 77
- +2 ;
- +3 ; ******************************************************************
- +4 ; CHANGE LOG
- +5 ;
- +6 ; DATE PATCH DESCRIPTION
- +7 ; ---- ----- -----------
- +8 ;
- +9 ;
- +10 NEW SDWLERR,SDWLOPT,SDWLSCL,SDWLHD,SDWLIN1,SDWLIN2,SDWLCL0,SDWLCL1,SDWLCL2,SDWLCSC1,SDWLCSC2,SDWLCM
- +11 SET SDWLHD="Scheduling/PCMM Batch Change EWL Clinic"
- +12 if $DATA(IOF)
- WRITE @IOF
- WRITE !?80-$LENGTH(SDWLHD)\2,SDWLHD,!
- +13 SET SDWLERR=0
- SET SDWLOPT=1
- SET (SDWLIN2,SDWLCL1,SDWLCL2,SDWLCM)=""
- SET SDWLIN1=+$$SITE^VASITE()
- +14 FOR
- DO @("P"_SDWLOPT)
- if 'SDWLOPT
- QUIT
- +15 QUIT
- P1 ; Source Institution
- +1 SET DIR(0)="PAO^DIC(4,:EMNZ"
- +2 SET DIR("A")="Select Source Institution: "
- +3 IF SDWLIN1'=""
- SET DIR("B")=$$GET1^DIQ(4,SDWLIN1,.01)
- +4 SET DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
- +5 DO ^DIR
- +6 IF Y<1
- SET SDWLOPT=0
- QUIT
- +7 SET (SDWLIN1,SDWLIN2)=+Y
- SET SDWLOPT=SDWLOPT+1
- +8 QUIT
- P2 ; Source Clinic
- +1 NEW DIR,SDWLSC
- +2 SET DIR(0)="PAO^SDWL(409.32,:EMNZ"
- +3 SET DIR("A")="Select Source Clinic: "
- +4 IF SDWLCL1'=""
- SET DIR("B")=$$GET1^DIQ(409.32,SDWLCL1,.01)
- +5 SET DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN1"
- +6 DO ^DIR
- +7 IF Y="^"
- SET SDWLOPT=0
- QUIT
- +8 IF Y<1
- SET SDWLOPT=SDWLOPT-1
- QUIT
- +9 ; Wait list specific clinic
- SET SDWLCL0=+Y
- +10 ; pointer to HOSPITAL LOCATION file
- SET SDWLCL1=$PIECE(Y,U,2)
- +11 ; Clinic stop code
- SET SDWLCSC1=$$GET1^DIQ(44,SDWLCL1,8,"I")_U_$$GET1^DIQ(44,SDWLCL1,8)
- +12 SET SDWLOPT=SDWLOPT+1
- +13 QUIT
- P3 ; Destination Institution
- +1 SET DIR(0)="PAO^DIC(4,:EMNZ"
- +2 SET DIR("A")="Select Destination Institution: "
- +3 IF SDWLIN1'=""
- SET DIR("B")=$$GET1^DIQ(4,SDWLIN2,.01)
- +4 SET DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
- +5 DO ^DIR
- +6 IF Y="^"
- SET SDWLOPT=0
- QUIT
- +7 IF Y<1
- SET SDWLOPT=SDWLOPT-1
- QUIT
- +8 SET SDWLIN2=+Y
- SET SDWLOPT=SDWLOPT+1
- +9 QUIT
- P4 ; Destination Clinic
- +1 NEW DIR,SDWLSC,SDWLY
- +2 SET DIR(0)="PAO^SDWL(409.32,:EMNZ"
- +3 SET DIR("A")="Select Destination Clinic: "
- +4 IF SDWLCL2'=""
- SET DIR("B")=$$GET1^DIQ(409.32,SDWLCL2,.01)
- +5 SET DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN2,+Y'=SDWLCL0"
- +6 DO ^DIR
- +7 IF Y="^"
- SET SDWLOPT=0
- QUIT
- +8 IF Y<1
- SET SDWLOPT=SDWLOPT-1
- QUIT
- +9 ; pointer to HOSPITAL LOCATION file
- SET SDWLY=+Y
- SET SDWLSC=$PIECE(Y,U,2)
- +10 ; get clinic's stop code. warn if different.
- +11 ; Clinic's stop code
- SET SDWLCSC2=$$GET1^DIQ(44,SDWLSC,8,"I")_U_$$GET1^DIQ(44,SDWLSC,8)
- +12 IF +SDWLCSC1'=+SDWLCSC2
- Begin DoDot:1
- +13 SET DIR(0)="Y"
- +14 SET DIR("A")="The clinics' stop codes are different, continue"
- +15 SET DIR("A",1)=$$GET1^DIQ(409.32,SDWLCL1,.01)_": "_$PIECE(SDWLCSC1,U,2)_" ("_+SDWLCSC1_")"
- +16 SET DIR("A",2)=$$GET1^DIQ(409.32,+Y,.01)_": "_$PIECE(SDWLCSC2,U,2)_" ("_+SDWLCSC2_")"
- +17 SET DIR("B")="YES"
- +18 DO ^DIR
- +19 if Y="^"
- SET SDWLOPT=0
- +20 QUIT
- End DoDot:1
- if 'Y
- QUIT
- +21 SET SDWLSCL=SDWLY
- SET SDWLOPT=SDWLOPT+1
- +22 QUIT
- P5 ; Comment
- +1 DO P4^SDWLE6
- +2 QUIT
- P6 ; Confirmation and processing
- +1 NEW DIR,Y
- +2 SET DIR(0)="Y"
- +3 SET DIR("A")="Proceed with batch clinic change"
- +4 SET DIR("B")="YES"
- +5 DO ^DIR
- +6 if Y
- DO CHNGCL
- +7 SET SDWLOPT=0
- +8 QUIT
- CHNGCL ;
- +1 NEW DIR,SDWLDA,SDWLCNT
- +2 SET SDWLDA=""
- SET SDWLCNT=0
- +3 FOR
- SET SDWLDA=$ORDER(^SDWL(409.3,"SC",SDWLCL1,SDWLDA))
- if 'SDWLDA
- QUIT
- Begin DoDot:1
- +4 NEW DA,DIE,DIR,DR,SDWLDFN,SDWLIN,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLCL1,SDWLDDT,SDWLEEST,Y
- +5 DO GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;23;27","I","SDWLTMP")
- +6 ; Only open entries.
- if SDWLTMP(409.3,SDWLDA_",",23,"I")="C"
- QUIT
- +7 SET SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
- +8 SET SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
- +9 SET SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
- +10 SET SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
- +11 SET SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
- +12 SET SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
- +13 if '$$UPDATE^SDWLE7(SDWLDFN,SDWLORDT,SDWLIN2,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA)
- QUIT
- +14 ; disposition old entry
- +15 SET DIE="^SDWL(409.3,"
- SET DA=SDWLDA
- SET DR="19////^S X=DT;20////^S X=DUZ;21////^S X=""CL"";23////^S X=""C"""
- +16 DO ^DIE
- +17 SET SDWLCNT=SDWLCNT+1
- +18 QUIT
- End DoDot:1
- +19 WRITE !
- if SDWLCNT
- WRITE "Clinics changed. "
- WRITE SDWLCNT," entries processed."
- +20 SET DIR(0)="E"
- DO ^DIR
- +21 QUIT
- CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
- +1 ; function to return:
- +2 ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ Inst Name _U_ Div Pointer to ^DG(40.8 _U_N/L_U_Message
- +3 ; ( INST^STA NUM^SNAM^DIV^N/L^MESS )
- +4 ; N/L - N -National/L -Local
- +5 ; with Message:
- +6 ; - if STA="" INST^^SNAM^DIV^^N/L^' - No Station Number on file'
- +7 ; or
- +8 ; - 0^^^DIV^^' - No Institution has been identified'
- +9 ; - 0^^^-1^^' - no Division has been identified'
- +10 ; - -1 no clinic on file'
- +11 IF '$DATA(^SC(+CL))
- QUIT -1_"^^^^^no clinic on file"
- +12 NEW SDWMES,STN,DIV,INS,SNL,STR,SNAM
- SET SDWMES=""
- SET STN=""
- +13 SET DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
- +14 IF DIV=0
- SET SDWMES="no Division has been identified"
- QUIT 0_"^^^"_-1_"^^"_SDWMES
- +15 SET INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
- +16 IF INS=0
- SET SDWMES="No Institution has been identified"
- QUIT 0_"^^^"_DIV_"^"_SDWMES
- +17 ;station number and name
- IF '$TEST
- SET STR=$$NS^XUAF4(INS)
- SET STN=$PIECE(STR,U,2)
- SET SNAM=$PIECE(STR,U)
- +18 IF STN=""
- SET SDWMES="No Station Number on file"
- +19 IF '$$TF^XUAF4(INS)
- SET SDWMES="Inactive treating medical facility"
- +20 SET SNL=$$GET1^DIQ(4,INS_",",11,"I")
- +21 QUIT INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES