- SD53726P ;MNT/BJR - REMAP CLINICS 726 POST INSTALL ;4/2/19 10:04am
- ;;5.3;Scheduling;**726**;Aug 13, 1993;Build 36
- ;
- Q
- ;Calls to XLFDT supported by ICR #10103
- ;Call to %ZTLOAD supported by ICR #10063
- ;Call to %ZISC supported by ICR #10089
- ;Call to BMES^XPDUTL supported by ICR #10141
- ;
- EN ;Entry point for post install to remap clinics
- D RMVMES,ADDT,CANC
- N BEGDATE,ENDDATE,VAUTD,VAUTC,SDBD,SDED,SDIEN,SDQMES
- S BEGDATE=DT,ENDDATE=$$FMADD^XLFDT(DT,365),SDBD=DT,SDED=ENDDATE,VAUTD=1
- S SDVAR1="SDBD^SDED^VAUTD#^VAUTC#^DUZ^BEGDATE^ENDDATE",SDPGM="START^SDD",SDFZIS=1
- S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN D
- .I $G(^SC(SDIEN,"I")) I +^SC(SDIEN,"I")>=DT!(+^SC(SDIEN,"I")<=DT&(($P(^SC(SDIEN,"I"),U,2)>=DT)!($P(^SC(SDIEN,"I"),U,2)=""))) Q
- .S ZTIO=$G(XPDQUES("POS1")),ZTDTH=$$NOW^XLFDT
- .S ZTDESC=SDPGM,ZTRTN=SDPGM,SDZTSAVE=SDVAR1
- .S VAUTC=0,VAUTC($P(^SC(SDIEN,0),U))=SDIEN D
- ..I $D(SDPGM),'$D(ZTSAVE("SDPGM")) S ZTSAVE("SDPGM")="" D SAVE
- D ^%ZTLOAD
- S SDQMES=$S($D(ZTSK):"Request Queued!",1:"Request Failed!") D BMES^XPDUTL(SDQMES) D CLOSE:$D(ZTSK)
- D END1
- Q
- RMVMES ;Remove MESSAGE (#1400) fields w/o corresponding SDCAN to ensure clinic grid builds properly
- N SDIEN,SDDT,SDMES
- S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN S SDDT=0 F S SDDT=$O(^SC(SDIEN,"S",SDDT)) Q:'SDDT D
- .I $D(^SC(SDIEN,"S",SDDT,"MES")),'$D(^SC(SDIEN,"SDCAN",SDDT,0)),SDDT>=DT K ^SC(SDIEN,"S",SDDT,"MES") D
- ..S SDMES=$P(^SC(SDIEN,0),U)_" message field removed for "_$$FMTE^XLFDT(SDDT) D BMES^XPDUTL(SDMES)
- Q
- ADDT ;Add any missing "T" zero nodes to ensure clinic grid builds properly
- N SDIEN,SDDT,SDMES
- S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN S SDDT=0 F S SDDT=$O(^SC(SDIEN,"T",SDDT)) Q:'SDDT D
- .I $D(^SC(SDIEN,"T",SDDT)),'$D(^SC(SDIEN,"T",SDDT,0)) S ^SC(SDIEN,"T",SDDT,0)=SDDT
- Q
- CANC ; Cancel appt in 44 that are canceled in 2
- N SDIEN,SDDT,SDCLIN,SDAPPT,SDMES,DIE,DA,DR
- S SDIEN=0 F S SDIEN=$O(^DPT(SDIEN)) Q:'SDIEN S SDDT=DT F S SDDT=$O(^DPT(SDIEN,"S",SDDT)) Q:'SDDT D
- .I $P(^DPT(SDIEN,"S",SDDT,0),U,2)["C" S SDCLIN=$P(^DPT(SDIEN,"S",SDDT,0),U) I $D(^SC(SDCLIN,"S",SDDT,0)) D
- ..S SDAPPT=0 F S SDAPPT=$O(^SC(SDCLIN,"S",SDDT,1,SDAPPT)) Q:'SDAPPT D
- ...I +^SC(SDCLIN,"S",SDDT,1,SDAPPT,0)=SDIEN,$P(^SC(SDCLIN,"S",SDDT,1,SDAPPT,0),U,9)'="C" D
- ....S DIE="^SC("_SDCLIN_",""S"","_SDDT_",1,",DA(2)=SDCLIN,DA(1)=SDDT,DA=SDAPPT,DR="310///C;3///Canceled by patch SD*5.3*726" D ^DIE
- ....S SDMES="Appointment for patient "_$P(^DPT(SDIEN,0),U)_" at "_$P(^SC(SDCLIN,0),U)_" at "_$$FMTE^XLFDT(SDDT)_" has been canceled in the Hospital Location file."
- ....D BMES^XPDUTL(SDMES)
- Q
- SAVE ;Set up save variable for routine
- D:SDZTSAVE["#" ARRAY F SDI=1:1 S SDVAR=$P(SDZTSAVE,"^",SDI) Q:SDVAR']"" I '$D(ZTSAVE(SDVAR)) S ZTSAVE(SDVAR)="" S:$E(SDVAR,$L(SDVAR))="(" ZTSAVE($E(SDVAR,1,($L(SDVAR)-1)))=""
- Q
- ARRAY ;Set up routine array
- F SDJ=1:1:$L(SDZTSAVE) I $E(SDZTSAVE,SDJ)="#" S SDZTSAVE=$E(SDZTSAVE,1,(SDJ-1))_"("_$E(SDZTSAVE,SDJ+1,$L(SDZTSAVE))
- Q
- CLOSE Q:$D(ZTQUEUED) N POP D ^%ZISC
- END ;Clean up variables
- K ZTSK,ZTDESCZTREQ,ZTSAVE,ZTUCI,ZTQUEUED Q
- END1 ;Clean up Variables
- K SDVAR,SDPGM,SDZTSAVE,SDI,SDJ,SDFZIS,ZTIO,ZTDTH,ZTRTN,ZTDESC,%ZIS,XPDQUES,IO("Q"),IO("C"),SDVAR1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53726P 3242 printed Mar 13, 2025@21:50:20 Page 2
- SD53726P ;MNT/BJR - REMAP CLINICS 726 POST INSTALL ;4/2/19 10:04am
- +1 ;;5.3;Scheduling;**726**;Aug 13, 1993;Build 36
- +2 ;
- +3 QUIT
- +4 ;Calls to XLFDT supported by ICR #10103
- +5 ;Call to %ZTLOAD supported by ICR #10063
- +6 ;Call to %ZISC supported by ICR #10089
- +7 ;Call to BMES^XPDUTL supported by ICR #10141
- +8 ;
- EN ;Entry point for post install to remap clinics
- +1 DO RMVMES
- DO ADDT
- DO CANC
- +2 NEW BEGDATE,ENDDATE,VAUTD,VAUTC,SDBD,SDED,SDIEN,SDQMES
- +3 SET BEGDATE=DT
- SET ENDDATE=$$FMADD^XLFDT(DT,365)
- SET SDBD=DT
- SET SDED=ENDDATE
- SET VAUTD=1
- +4 SET SDVAR1="SDBD^SDED^VAUTD#^VAUTC#^DUZ^BEGDATE^ENDDATE"
- SET SDPGM="START^SDD"
- SET SDFZIS=1
- +5 SET SDIEN=0
- FOR
- SET SDIEN=$ORDER(^SC(SDIEN))
- if 'SDIEN
- QUIT
- Begin DoDot:1
- +6 IF $GET(^SC(SDIEN,"I"))
- IF +^SC(SDIEN,"I")>=DT!(+^SC(SDIEN,"I")<=DT&(($PIECE(^SC(SDIEN,"I"),U,2)>=DT)!($PIECE(^SC(SDIEN,"I"),U,2)="")))
- QUIT
- +7 SET ZTIO=$GET(XPDQUES("POS1"))
- SET ZTDTH=$$NOW^XLFDT
- +8 SET ZTDESC=SDPGM
- SET ZTRTN=SDPGM
- SET SDZTSAVE=SDVAR1
- +9 SET VAUTC=0
- SET VAUTC($PIECE(^SC(SDIEN,0),U))=SDIEN
- Begin DoDot:2
- +10 IF $DATA(SDPGM)
- IF '$DATA(ZTSAVE("SDPGM"))
- SET ZTSAVE("SDPGM")=""
- DO SAVE
- End DoDot:2
- End DoDot:1
- +11 DO ^%ZTLOAD
- +12 SET SDQMES=$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Failed!")
- DO BMES^XPDUTL(SDQMES)
- if $DATA(ZTSK)
- DO CLOSE
- +13 DO END1
- +14 QUIT
- RMVMES ;Remove MESSAGE (#1400) fields w/o corresponding SDCAN to ensure clinic grid builds properly
- +1 NEW SDIEN,SDDT,SDMES
- +2 SET SDIEN=0
- FOR
- SET SDIEN=$ORDER(^SC(SDIEN))
- if 'SDIEN
- QUIT
- SET SDDT=0
- FOR
- SET SDDT=$ORDER(^SC(SDIEN,"S",SDDT))
- if 'SDDT
- QUIT
- Begin DoDot:1
- +3 IF $DATA(^SC(SDIEN,"S",SDDT,"MES"))
- IF '$DATA(^SC(SDIEN,"SDCAN",SDDT,0))
- IF SDDT>=DT
- KILL ^SC(SDIEN,"S",SDDT,"MES")
- Begin DoDot:2
- +4 SET SDMES=$PIECE(^SC(SDIEN,0),U)_" message field removed for "_$$FMTE^XLFDT(SDDT)
- DO BMES^XPDUTL(SDMES)
- End DoDot:2
- End DoDot:1
- +5 QUIT
- ADDT ;Add any missing "T" zero nodes to ensure clinic grid builds properly
- +1 NEW SDIEN,SDDT,SDMES
- +2 SET SDIEN=0
- FOR
- SET SDIEN=$ORDER(^SC(SDIEN))
- if 'SDIEN
- QUIT
- SET SDDT=0
- FOR
- SET SDDT=$ORDER(^SC(SDIEN,"T",SDDT))
- if 'SDDT
- QUIT
- Begin DoDot:1
- +3 IF $DATA(^SC(SDIEN,"T",SDDT))
- IF '$DATA(^SC(SDIEN,"T",SDDT,0))
- SET ^SC(SDIEN,"T",SDDT,0)=SDDT
- End DoDot:1
- +4 QUIT
- CANC ; Cancel appt in 44 that are canceled in 2
- +1 NEW SDIEN,SDDT,SDCLIN,SDAPPT,SDMES,DIE,DA,DR
- +2 SET SDIEN=0
- FOR
- SET SDIEN=$ORDER(^DPT(SDIEN))
- if 'SDIEN
- QUIT
- SET SDDT=DT
- FOR
- SET SDDT=$ORDER(^DPT(SDIEN,"S",SDDT))
- if 'SDDT
- QUIT
- Begin DoDot:1
- +3 IF $PIECE(^DPT(SDIEN,"S",SDDT,0),U,2)["C"
- SET SDCLIN=$PIECE(^DPT(SDIEN,"S",SDDT,0),U)
- IF $DATA(^SC(SDCLIN,"S",SDDT,0))
- Begin DoDot:2
- +4 SET SDAPPT=0
- FOR
- SET SDAPPT=$ORDER(^SC(SDCLIN,"S",SDDT,1,SDAPPT))
- if 'SDAPPT
- QUIT
- Begin DoDot:3
- +5 IF +^SC(SDCLIN,"S",SDDT,1,SDAPPT,0)=SDIEN
- IF $PIECE(^SC(SDCLIN,"S",SDDT,1,SDAPPT,0),U,9)'="C"
- Begin DoDot:4
- +6 SET DIE="^SC("_SDCLIN_",""S"","_SDDT_",1,"
- SET DA(2)=SDCLIN
- SET DA(1)=SDDT
- SET DA=SDAPPT
- SET DR="310///C;3///Canceled by patch SD*5.3*726"
- DO ^DIE
- +7 SET SDMES="Appointment for patient "_$PIECE(^DPT(SDIEN,0),U)_" at "_$PIECE(^SC(SDCLIN,0),U)_" at "_$$FMTE^XLFDT(SDDT)_" has been canceled in the Hospital Location file."
- +8 DO BMES^XPDUTL(SDMES)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 QUIT
- SAVE ;Set up save variable for routine
- +1 if SDZTSAVE["#"
- DO ARRAY
- FOR SDI=1:1
- SET SDVAR=$PIECE(SDZTSAVE,"^",SDI)
- if SDVAR']""
- QUIT
- IF '$DATA(ZTSAVE(SDVAR))
- SET ZTSAVE(SDVAR)=""
- if $EXTRACT(SDVAR,$LENGTH(SDVAR))="("
- SET ZTSAVE($EXTRACT(SDVAR,1,($LENGTH(SDVAR)-1)))=""
- +2 QUIT
- ARRAY ;Set up routine array
- +1 FOR SDJ=1:1:$LENGTH(SDZTSAVE)
- IF $EXTRACT(SDZTSAVE,SDJ)="#"
- SET SDZTSAVE=$EXTRACT(SDZTSAVE,1,(SDJ-1))_"("_$EXTRACT(SDZTSAVE,SDJ+1,$LENGTH(SDZTSAVE))
- +2 QUIT
- CLOSE if $DATA(ZTQUEUED)
- QUIT
- NEW POP
- DO ^%ZISC
- END ;Clean up variables
- +1 KILL ZTSK,ZTDESCZTREQ,ZTSAVE,ZTUCI,ZTQUEUED
- QUIT
- END1 ;Clean up Variables
- +1 KILL SDVAR,SDPGM,SDZTSAVE,SDI,SDJ,SDFZIS,ZTIO,ZTDTH,ZTRTN,ZTDESC,%ZIS,XPDQUES,IO("Q"),IO("C"),SDVAR1
- +2 QUIT
